packdeps 0.3.0.1 → 0.6.0.0
raw patch · 7 files changed
Files
- ChangeLog.md +31/−0
- Distribution/PackDeps.hs +0/−258
- README.md +6/−0
- packdeps.cabal +23/−42
- src/Distribution/PackDeps.hs +400/−0
- tools/packdeps-cli.hs +129/−52
- tools/packdeps-yesod.hs +0/−441
+ ChangeLog.md view
@@ -0,0 +1,31 @@+# ChangeLog for packdeps++## 0.6.0.0++* Switch to Cabal 3.2++## 0.5.0.0++* Switch to Cabal 3.0++## 0.4.5++* Switch to Cabal 2.2+* Add preferred switch++## 0.4.4++* Switch over to Cabal 2.0. (Normally it would be better to keep+ backwards compat, but the API breakage is too high.)++## 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)++## 0.4.1++* Cli improvements: UI tweaks and --recursive flag [#28](https://github.com/snoyberg/packdeps/pull/28)
− Distribution/PackDeps.hs
@@ -1,258 +0,0 @@-module Distribution.PackDeps- ( -- * Data types- Newest- , CheckDepsRes (..)- , DescInfo- -- * Read package database- , loadNewest- , loadNewestFrom- , parseNewest- -- * Check a package- , checkDeps- -- * Get a single package- , getPackage- , parsePackage- , loadPackage- -- * Get multiple packages- , filterPackages- , deepDeps- -- * Reverse dependencies- , Reverses- , getReverses- -- * Helpers- , diName- -- * Internal- , PackInfo (..)- , DescInfo (..)- ) where--import System.Directory (getAppUserDataDirectory)-import System.FilePath ((</>))-import qualified Data.Map as Map-import Data.List (foldl', group, sort, isInfixOf, isPrefixOf)-import Data.Time (UTCTime (UTCTime), addUTCTime)-import Data.Maybe (mapMaybe, catMaybes)-import Control.Exception (throw)--import Distribution.Package-import Distribution.PackageDescription-import Distribution.PackageDescription.Parse-import Distribution.Version-import Distribution.Text--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-import qualified Data.ByteString.Lazy as L--import Data.List.Split (splitOn)-import qualified Codec.Archive.Tar as Tar-import qualified Codec.Archive.Tar.Entry as Tar--import Data.Function (on)-import Control.Arrow ((&&&))-import Data.List (groupBy, sortBy)-import Data.Ord (comparing)-import qualified Data.Set as Set--loadNewest :: IO Newest-loadNewest = do- c <- getAppUserDataDirectory "cabal"- cfg <- readFile (c </> "config")- let repos = reposFromConfig cfg- tarName repo = c </> "packages" </> repo </> "00-index.tar"- fmap (Map.unionsWith maxVersion) . mapM (loadNewestFrom . tarName) $ repos--reposFromConfig :: String -> [String]-reposFromConfig = map (takeWhile (/= ':'))- . catMaybes- . map (dropPrefix "remote-repo: ")- . lines--dropPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]-dropPrefix prefix s =- if prefix `isPrefixOf` s- then Just . drop (length prefix) $ s- else Nothing--loadNewestFrom :: FilePath -> IO Newest-loadNewestFrom = fmap parseNewest . L.readFile--parseNewest :: L.ByteString -> Newest-parseNewest = foldl' addPackage Map.empty . entriesToList . Tar.read--entriesToList :: Tar.Entries Tar.FormatError -> [Tar.Entry]-entriesToList Tar.Done = []-entriesToList (Tar.Fail s) = throw s-entriesToList (Tar.Next e es) = e : entriesToList es--addPackage :: Newest -> Tar.Entry -> Newest-addPackage m entry =- case splitOn "/" $ Tar.fromTarPathToPosixPath (Tar.entryTarPath entry) of- [package', versionS, _] ->- case simpleParse versionS of- Just version ->- case Map.lookup package' m of- Nothing -> go package' version- Just PackInfo { piVersion = oldv } ->- if version > oldv- then go package' version- else m- Nothing -> m- _ -> m- where- go package' version =- case Tar.entryContent entry of- Tar.NormalFile bs _ ->- Map.insert package' PackInfo- { piVersion = version- , piDesc = parsePackage bs- , piEpoch = Tar.entryTime entry- } m- _ -> m--data PackInfo = PackInfo- { piVersion :: Version- , piDesc :: Maybe DescInfo- , piEpoch :: Tar.EpochTime- }- deriving (Show, Read)--maxVersion :: PackInfo -> PackInfo -> PackInfo-maxVersion pi1 pi2 = if piVersion pi1 <= piVersion pi2 then pi2 else pi1---- | The newest version of every package.-type Newest = Map.Map String PackInfo--type Reverses = Map.Map String (Version, [(String, VersionRange)])--getReverses :: Newest -> Reverses-getReverses newest =- Map.fromList withVersion- where- -- dep = dependency, rel = relying package- toTuples (_, PackInfo { piDesc = Nothing }) = []- toTuples (rel, PackInfo { piDesc = Just DescInfo { diDeps = deps } }) =- map (toTuple rel) deps- toTuple rel (Dependency (PackageName dep) range) = (dep, (rel, range))- hoist :: Ord a => [(a, b)] -> [(a, [b])]- hoist = map ((fst . head) &&& map snd)- . groupBy ((==) `on` fst)- . sortBy (comparing fst)- hoisted = hoist $ concatMap toTuples $ Map.toList newest- withVersion = mapMaybe addVersion hoisted- addVersion (dep, rels) =- case Map.lookup dep newest of- Nothing -> Nothing- Just PackInfo { piVersion = v} -> Just (dep, (v, rels))---- | Information on a single package.-data DescInfo = DescInfo- { diHaystack :: String- , diDeps :: [Dependency]- , diPackage :: PackageIdentifier- , diSynopsis :: String- }- deriving (Show, Read)--getDescInfo :: GenericPackageDescription -> DescInfo-getDescInfo gpd = DescInfo- { diHaystack = map toLower $ author p ++ maintainer p ++ name- , diDeps = getDeps gpd- , diPackage = pi'- , diSynopsis = synopsis p- }- where- p = packageDescription gpd- pi'@(PackageIdentifier (PackageName name) _) = package p--getDeps :: GenericPackageDescription -> [Dependency]-getDeps x = concat- $ maybe id ((:) . condTreeConstraints) (condLibrary x)- $ map (condTreeConstraints . snd) (condExecutables x)--checkDeps :: Newest -> DescInfo- -> (PackageName, Version, CheckDepsRes)-checkDeps newest desc =- case mapMaybe (notNewest newest) $ diDeps desc of- [] -> (name, version, AllNewest)- x -> let y = map head $ group $ sort $ map fst x- et = maximum $ map snd x- in (name, version, WontAccept y $ epochToTime et)- where- PackageIdentifier name version = diPackage desc---- | Whether or not a package can accept all of the newest versions of its--- dependencies. If not, it returns a list of packages which are not accepted,--- and a timestamp of the most recently updated package.-data CheckDepsRes = AllNewest- | WontAccept [(String, String)] UTCTime- deriving Show--epochToTime :: Tar.EpochTime -> UTCTime-epochToTime e = addUTCTime (fromIntegral e) $ UTCTime (read "1970-01-01") 0--notNewest :: Newest -> Dependency -> Maybe ((String, String), Tar.EpochTime)-notNewest newest (Dependency (PackageName s) range) =- case Map.lookup s newest of- --Nothing -> Just ((s, " no version found"), 0)- Nothing -> Nothing- Just PackInfo { piVersion = version, piEpoch = e } ->- if withinRange version range- then Nothing- else Just ((s, display version), e)---- | Loads up the newest version of a package from the 'Newest' list, if--- available.-getPackage :: String -> Newest -> Maybe DescInfo-getPackage s n = Map.lookup s n >>= piDesc---- | Parse information on a package from the contents of a cabal file.-parsePackage :: L.ByteString -> Maybe DescInfo-parsePackage lbs =- case parsePackageDescription $ T.unpack- $ T.decodeUtf8With T.lenientDecode lbs of- ParseOk _ x -> Just $ getDescInfo x- _ -> Nothing---- | Load a single package from a cabal file.-loadPackage :: FilePath -> IO (Maybe DescInfo)-loadPackage = fmap parsePackage . L.readFile---- | Find all of the packages matching a given search string.-filterPackages :: String -> Newest -> [DescInfo]-filterPackages needle =- mapMaybe go . Map.elems- where- needle' = map toLower needle- go PackInfo { piDesc = Just desc } =- if needle' `isInfixOf` diHaystack desc &&- not ("(deprecated)" `isInfixOf` diSynopsis desc)- then Just desc- else Nothing- go _ = Nothing---- | Find all packages depended upon by the given list of packages.-deepDeps :: Newest -> [DescInfo] -> [DescInfo]-deepDeps newest dis0 =- go Set.empty dis0- where- go _ [] = []- go viewed (di:dis)- | name `Set.member` viewed = go viewed dis- | otherwise = di : go viewed' (newDis ++ dis)- where- PackageIdentifier (PackageName name) _ = diPackage di- viewed' = Set.insert name viewed- newDis = mapMaybe getDI $ diDeps di- getDI :: Dependency -> Maybe DescInfo- getDI (Dependency (PackageName name') _) = do- pi' <- Map.lookup name' newest- piDesc pi'--diName :: DescInfo -> String-diName =- unPN . pkgName . diPackage- where- unPN (PackageName pn) = pn
+ README.md view
@@ -0,0 +1,6 @@+## packdeps++[](https://travis-ci.org/snoyberg/packdeps)++Check the upper bounds on a package to determine if there are newer versions of+dependencies.
packdeps.cabal view
@@ -1,5 +1,5 @@ name: packdeps-version: 0.3.0.1+version: 0.6.0.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -11,61 +11,42 @@ The command line tool has an incredibly simple interface: simply pass it a list of cabal files, and it will tell you what dependencies- if any- are restricted. category: Distribution stability: Stable-cabal-version: >= 1.8+cabal-version: >= 1.10 build-type: Simple homepage: http://packdeps.haskellers.com/--flag web- description: Build the web-based interface.- default: False+extra-source-files: README.md ChangeLog.md library- build-depends: base >= 4 && < 5- , tar >= 0.4 && < 0.5- , split >= 0.1.2.3 && < 0.2- , bytestring >= 0.9 && < 0.10- , text >= 0.7 && < 0.12- , Cabal >= 1.8 && < 1.15+ default-language: Haskell2010+ hs-source-dirs: src+ build-depends: base >= 4.14 && < 5+ , tar >= 0.4 && < 0.6+ , split >= 0.1.2.3+ , bytestring >= 0.9+ , text >= 0.7+ , Cabal >= 3.2 && < 3.3 , time >= 1.1.4 , containers >= 0.2- , directory >= 1.0 && < 1.2- , filepath >= 1.1 && < 1.4+ , directory >= 1.0+ , filepath >= 1.1 exposed-modules: Distribution.PackDeps ghc-options: -Wall executable packdeps+ default-language: Haskell2010 main-is: packdeps-cli.hs hs-source-dirs: tools - if flag(web)- Buildable: False- else- ghc-options: -Wall-- build-depends: base >= 4 && < 5- , Cabal- , packdeps--executable packdeps-yesod- main-is: packdeps-yesod.hs- hs-source-dirs: tools+ ghc-options: -Wall -rtsopts - if flag(web)- ghc-options: -Wall- build-depends: base >= 4 && < 5- , text- , bytestring- , containers- , Cabal- , time- , packdeps- , hamlet- , yesod-newsfeed- , yesod >= 0.10- , cautious-file >= 1.0 && < 1.1- , aeson >= 0.6 && < 0.7- else- Buildable: False+ build-depends: base >= 4.14 && < 5+ , Cabal+ , optparse-applicative >=0.14 && <0.16+ , containers+ , semigroups+ , process+ , packdeps+ , text source-repository head type: git
+ src/Distribution/PackDeps.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+module Distribution.PackDeps+ ( -- * Data types+ Newest+ , CheckDepsRes (..)+ , DescInfo+ -- * Read package database+ , loadNewest+ , loadNewestFrom+ , parseNewest+ -- * Check a package+ , checkDeps+ , checkLibDeps+ -- * Get a single package+ , getPackage+ , parsePackage+ , loadPackage+ -- * Get multiple packages+ , filterPackages+ , deepDeps+ , deepLibDeps+ -- * Reverse dependencies+ , Reverses+ , getReverses+ -- * Helpers+ , diName+ -- * Internal+ , PackInfo (..)+ , piRevision+ , DescInfo (..)+ ) where++import Control.Applicative as A ((<$>))+import Control.Monad (guard)+import System.Directory (getAppUserDataDirectory, doesFileExist)+import System.FilePath ((</>))+import qualified Data.Map.Strict as Map+import Data.List (foldl', group, sort, isInfixOf)+import Data.Time (UTCTime (UTCTime), addUTCTime)+import Data.Maybe (mapMaybe, fromMaybe)+import Control.Exception (throw)++import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Parsec+import Distribution.Parsec (Parsec, lexemeParsec, runParsecParser, simpleParsec)+import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)+import Distribution.Types.CondTree+import Distribution.Version+import Distribution.Utils.ShortText+import qualified Distribution.Utils.ShortText as ShortText+import qualified Distribution.Fields as F+import qualified Distribution.Fields.Field as F+import qualified Distribution.Simple.Utils as U++import Data.Char (toLower)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++import Data.List.Split (splitOn)+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar++import Data.Function (on)+import Control.Arrow ((&&&))+import Data.List (groupBy, sortBy)+import Data.Ord (comparing)+import qualified Data.Set as Set+import Text.Read (readMaybe)+import System.Environment (lookupEnv)+-- import Data.Monoid ((<>))++loadNewest :: Bool -> IO Newest+loadNewest preferred = do+ c <- getAppUserDataDirectory "cabal"+ location <- fmap (fromMaybe (c </> "config")) (lookupEnv "CABAL_CONFIG")++ cfg' <- S.readFile location+ cfg <- either (fail . show) return $ F.readFields cfg'+ let repos = reposFromConfig cfg+ repoCache = case lookupInConfig "remote-repo-cache" cfg of+ [] -> c </> "packages" -- Default+ (rrc : _) -> rrc -- User-specified+ tarNames repo = [ pfx </> "01-index.tar", pfx </> "00-index.tar" ]+ where pfx = repoCache </> repo+ fmap (Map.unionsWith maxVersion) . mapM (loadNewestFrom preferred . tarNames) $ repos++-- | Takes a list of possible pathes, tries them in order until one exists.+loadNewestFrom :: Bool -> [FilePath] -> IO Newest+loadNewestFrom _ [] = fail "loadNewestFrom: no index tarball"+loadNewestFrom preferred (fp : fps) = do+ e <- doesFileExist fp+ if e+ then fmap (parseNewest preferred) (L.readFile fp)+ else loadNewestFrom preferred fps++parseNewest :: Bool -> L.ByteString -> Newest+parseNewest preferred lbs =+ foldl' (addPackage pref) Map.empty . entriesToList . Tar.read $ lbs+ where+ pref | preferred = parsePreferred lbs+ | otherwise = Map.empty++parsePreferred :: L.ByteString -> Preferred+parsePreferred = foldl' addPreferred Map.empty . entriesToList . Tar.read++entriesToList :: Tar.Entries Tar.FormatError -> [Tar.Entry]+entriesToList Tar.Done = []+entriesToList (Tar.Fail s) = throw s+entriesToList (Tar.Next e es) = e : entriesToList es++addPackage :: Preferred -> Newest -> Tar.Entry -> Newest+addPackage pref m entry =+ case splitOn "/" $ Tar.fromTarPathToPosixPath (Tar.entryTarPath entry) of+ [packageS, versionS, _] -> fromMaybe m $ do+ package' <- simpleParsec packageS+ version <- simpleParsec versionS++ -- if there are preferred versions, consider only them+ guard (maybe True (withinRange version) $ Map.lookup package' pref)++ case Map.lookup package' m of+ Nothing -> return $ go package' version+ Just PackInfo { piVersion = oldv } -> do+ -- in 01-index.tar there are entries with the same versions+ guard (version >= oldv)+ return $ go package' version+ _ -> m -- error (show entry)+ where+ go package' version =+ case Tar.entryContent entry of+ Tar.NormalFile lbs _ ->+ let bs = S.copy (L.toStrict lbs)+ in bs `seq` Map.insertWith maxVersion package' PackInfo+ { piVersion = version+ , piDesc = parsePackage bs+ , piEpoch = Tar.entryTime entry+ } m+ _ -> m++addPreferred :: Preferred -> Tar.Entry -> Preferred+addPreferred m entry =+ case splitOn "/" $ Tar.fromTarPathToPosixPath (Tar.entryTarPath entry) of+ [_packageS, "preferred-versions"] ->+ case Tar.entryContent entry of+ Tar.NormalFile bs _ -> case simpleParsecLBS bs of+ Just (Dependency dep range _) -> Map.insert dep range m+ Nothing -> m+ _ -> m+ _ -> m++simpleParsecLBS :: Parsec a => L.ByteString -> Maybe a+simpleParsecLBS = either (const Nothing) Just+ . runParsecParser lexemeParsec "<simpleParsec>"+ . fieldLineStreamFromBS+ . S.copy+ . L.toStrict++data PackInfo = PackInfo+ { piVersion :: !Version+ , piDesc :: Maybe DescInfo -- this is deliberately lazy+ , 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++-- | The newest version of every package.+type Newest = Map.Map PackageName PackInfo++-- | The preferred versions of every package+type Preferred = Map.Map PackageName VersionRange++type Reverses = Map.Map PackageName (Version, [(PackageName, VersionRange)])++getReverses :: Newest -> Reverses+getReverses newest =+ Map.fromList withVersion+ where+ -- dep = dependency, rel = relying package+ toTuples (_, PackInfo { piDesc = Nothing }) = []+ toTuples (rel, PackInfo { piDesc = Just DescInfo { diDeps = deps } }) =+ map (toTuple rel) deps+ toTuple rel (Dependency dep range _) = (dep, (rel, range))+ hoist :: Ord a => [(a, b)] -> [(a, [b])]+ hoist = map ((fst . head) &&& map snd)+ . groupBy ((==) `on` fst)+ . sortBy (comparing fst)+ hoisted = hoist $ concatMap toTuples $ Map.toList newest+ withVersion = mapMaybe addVersion hoisted+ addVersion (dep, rels) =+ case Map.lookup dep newest of+ Nothing -> Nothing+ Just PackInfo { piVersion = v} -> Just (dep, (v, rels))++-- | Information on a single package.+data DescInfo = DescInfo+ { diHaystack :: ShortText+ , diDeps :: [Dependency]+ , diLibDeps :: [Dependency]+ , diPackage :: PackageIdentifier+ , diRevision :: Int+ , diSynopsis :: ShortText+ }+ deriving (Show, Read)++-- | Return revision and DescInfo+getDescInfo :: GenericPackageDescription -> DescInfo+getDescInfo gpd = DescInfo+ { diHaystack = ShortText.toShortText $+ map toLower $+ ShortText.fromShortText $+ author p <> maintainer p <> ShortText.toShortText name+ , diDeps = getDeps gpd+ , diLibDeps = getLibDeps gpd+ , diPackage = pi'+ , diRevision = rev+ , diSynopsis = synopsis p+ }+ where+ p = packageDescription gpd+ pi'@(PackageIdentifier (unPackageName -> name) _) = package p+ rev = fromMaybe 0 $ do+ r <- lookup "x-revision" (customFieldsPD p)+ readMaybe r++getDeps :: GenericPackageDescription -> [Dependency]+getDeps x = getLibDeps x ++ concat+ [ concatMap (condTreeConstraints' . snd) (condExecutables x)+ , concatMap (condTreeConstraints' . snd) (condTestSuites x)+ , concatMap (condTreeConstraints' . snd) (condBenchmarks x)+ ]++getLibDeps :: GenericPackageDescription -> [Dependency]+getLibDeps gpd = maybe [] condTreeConstraints' (condLibrary gpd) ++ customDeps+ where+ pd = packageDescription gpd+ customDeps+ | buildType pd == Custom = maybe defSetupDeps setupDepends (setupBuildInfo pd)+ | otherwise = []++ -- we only interested in Cabal default upper bound+ -- See cabal-install Distribution.Client.ProjectPlanning defaultSetupDeps+ defSetupDeps = [Dependency (mkPackageName "Cabal") (earlierVersion $ mkVersion [1,25]) mempty]++condTreeConstraints' :: Monoid c => CondTree ConfVar c a -> c+condTreeConstraints' = go where+ go (CondNode _ c bs) = mappend c (foldMap branch bs)++ branch (CondBranch c' x y)+ | notFlagCondition c' = mappend (go x) (foldMap go y)+ | otherwise = mempty++notFlagCondition :: Condition ConfVar -> Bool+notFlagCondition (Var (OS _)) = True+notFlagCondition (Var (Arch _)) = True+notFlagCondition (Var (Flag _)) = False+notFlagCondition (Var (Impl _ _)) = True+notFlagCondition (Lit _) = True+notFlagCondition (CNot a) = notFlagCondition a+notFlagCondition (COr a b) = notFlagCondition a && notFlagCondition b+notFlagCondition (CAnd a b) = notFlagCondition a && notFlagCondition b++checkDeps :: Newest -> DescInfo+ -> (PackageName, Version, CheckDepsRes)+checkDeps = checkDepsImpl diDeps++checkLibDeps :: Newest -> DescInfo+ -> (PackageName, Version, CheckDepsRes)+checkLibDeps = checkDepsImpl diLibDeps++checkDepsImpl :: (DescInfo -> [Dependency]) -> Newest -> DescInfo+ -> (PackageName, Version, CheckDepsRes)+checkDepsImpl deps newest desc =+ case mapMaybe (notNewest newest) $ deps desc of+ [] -> (name, version, AllNewest)+ x -> let y = map head $ group $ sort $ map fst x+ et = maximum $ map snd x+ in (name, version, WontAccept y $ epochToTime et)+ where+ PackageIdentifier name version = diPackage desc++-- | Whether or not a package can accept all of the newest versions of its+-- dependencies. If not, it returns a list of packages which are not accepted,+-- and a timestamp of the most recently updated package.+data CheckDepsRes = AllNewest+ | WontAccept [(PackageName, Version)] UTCTime+ deriving Show++epochToTime :: Tar.EpochTime -> UTCTime+epochToTime e = addUTCTime (fromIntegral e) $ UTCTime (read "1970-01-01") 0++notNewest :: Newest -> Dependency -> Maybe ((PackageName, Version), Tar.EpochTime)+notNewest newest (Dependency s range _public) =+ case Map.lookup s newest of+ --Nothing -> Just ((s, " no version found"), 0)+ Nothing -> Nothing+ Just PackInfo { piVersion = version, piEpoch = e } ->+ if withinRange version range+ then Nothing+ else Just ((s, version), e)++-- | Loads up the newest version of a package from the 'Newest' list, if+-- available.+getPackage :: PackageName -> Newest -> Maybe DescInfo+getPackage s n = Map.lookup s n >>= piDesc++-- | Parse information on a package from the contents of a cabal file.+parsePackage :: S.ByteString -> Maybe DescInfo+parsePackage bs =+ case snd $ runParseResult $ parseGenericPackageDescription bs of+ Right x -> Just $ getDescInfo x+ Left _ -> Nothing++-- | Load a single package from a cabal file.+loadPackage :: FilePath -> IO (Maybe DescInfo)+loadPackage = fmap parsePackage . S.readFile++-- | Find all of the packages matching a given search string.+filterPackages :: String -> Newest -> [DescInfo]+filterPackages needle =+ mapMaybe go . Map.elems+ where+ needle' = map toLower needle+ go PackInfo { piDesc = Just desc } =+ if needle' `isInfixOf` ShortText.fromShortText (diHaystack desc) &&+ not ("(deprecated)" `isInfixOf` ShortText.fromShortText (diSynopsis desc))+ then Just desc+ else Nothing+ go _ = Nothing++-- | Find all packages depended upon by the given list of packages.+deepDeps :: Newest -> [DescInfo] -> [DescInfo]+deepDeps = deepDepsImpl diDeps++-- | Find all packages depended upon by the given list of packages.+deepLibDeps :: Newest -> [DescInfo] -> [DescInfo]+deepLibDeps = deepDepsImpl diLibDeps++deepDepsImpl :: (DescInfo -> [Dependency]) -> Newest -> [DescInfo] -> [DescInfo]+deepDepsImpl deps newest dis0 =+ go Set.empty dis0+ where+ go _ [] = []+ go viewed (di:dis)+ | name `Set.member` viewed = go viewed dis+ | otherwise = di : go viewed' (newDis ++ dis)+ where+ PackageIdentifier name _ = diPackage di+ viewed' = Set.insert name viewed+ newDis = mapMaybe getDI $ deps di+ getDI :: Dependency -> Maybe DescInfo+ getDI (Dependency name' _ _) = do+ pi' <- Map.lookup name' newest+ piDesc pi'++diName :: DescInfo -> String+diName = unPackageName . pkgName . diPackage++-------------------------------------------------------------------------------+-- ~/.cabal/config parsing+-------------------------------------------------------------------------------++reposFromConfig :: [F.Field ann] -> [String]+reposFromConfig fields = takeWhile (/= ':') A.<$> mapMaybe f fields+ where+ f (F.Field (F.Name _pos name) fls)+ | name == "remote-repo"+ = Just $ U.fromUTF8BS $ S.intercalate "\n" (map F.fieldLineBS fls)+ f (F.Section (F.Name _pos secName) (F.SecArgName _ arg : _) _fields)+ | secName == "repository"+ = Just $ U.fromUTF8BS arg+ f _ = Nothing++-- | Looks up the given key in the cabal configuration file+lookupInConfig :: S.ByteString -> [F.Field ann] -> [String]+lookupInConfig key = mapMaybe f+ where+ f (F.Field (F.Name _pos name) fls)+ | name == key+ = Just $ U.fromUTF8BS $ S.intercalate "\n" (map F.fieldLineBS fls)+ f _ = Nothing++{-+-- | Like 'either', but for 'ParseResult'+parseResult :: (F.PError -> r) -> (a -> r) -> F.ParseResult a -> r+parseResult l _ (F.ParseFailed e) = l e+parseResult _ r (F.ParseOk _warns x) = r x+-}
tools/packdeps-cli.hs view
@@ -1,62 +1,139 @@+{-# LANGUAGE ViewPatterns #-}+import Control.Applicative (many, some)+import Control.Monad (forM_, foldM, when)+import Control.Monad (liftM)+import Data.Char (isSpace)+import Data.List (foldl') import Distribution.PackDeps-import Control.Monad (forM_)-import System.Environment (getArgs, getProgName)-import System.Exit (exitFailure, exitSuccess)+import Distribution.Package (PackageIdentifier (pkgName, pkgVersion), PackageName, unPackageName) import Distribution.Text (display)-import Distribution.Package (PackageName (PackageName))+import Distribution.Version (Version)+import qualified Distribution.InstalledPackageInfo as IPI+import System.Exit (exitFailure, exitSuccess)+import System.Process (readProcess)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8) +import qualified Data.Map as Map+import qualified Options.Applicative as O+ main :: IO () main = do- args <- getArgs- case args of- [] -> usageExit- ["help"] -> usageExit- _ -> run args+ run' <- O.execParser $ O.info (O.helper <*> opts) $ mconcat+ [ O.fullDesc+ , O.progDesc $ unwords+ [ "Check the given cabal file's dependency list to make sure that it does not exclude"+ , "the newest package available. It's probably worth running the 'cabal update' command"+ , "immediately before running this program."+ ]+ ]+ isGood <- run'+ if isGood then exitSuccess else exitFailure+ where+ opts = run+ <$> O.switch (O.short 'r' <> O.long "recursive" <> O.help "Check transitive dependencies as well.")+ <*> O.switch (O.short 'q' <> O.long "quiet" <> O.help "Suppress output for .cabal files which can accept the newest packages available.")+ <*> O.switch (O.short 'g' <> O.long "ghc-pkg" <> O.help "Use ghc-pkg list to additionally populate the newest packages database.")+ <*> O.switch (O.short 'p' <> O.long "preferred" <> O.help "Consider only preferred versions")+ <*> many (O.strOption (O.short 'e' <> O.long "exclude" <> O.metavar "pkgname" <> O.help "Exclude the package from the output."))+ <*> some (O.strArgument (O.metavar "pkgname.cabal")) -run :: [String] -> IO ()-run args = do- newest <- loadNewest- mapM_ (go newest) args+type CheckDeps = Newest -> DescInfo -> (PackageName, Version, CheckDepsRes)++checkDepsCli :: Bool -> [String] -> CheckDeps -> Newest -> DescInfo -> IO Bool+checkDepsCli quiet excludes cd newest di =+ case overTrd filterExcludes $ cd newest di of+ (pn, v, AllNewest)+ | quiet -> return True+ | otherwise -> do+ putStrLn $ concat+ [ unPackageName pn+ , "-"+ , display v+ , ": Can use newest versions of all dependencies"+ ]+ return True+ (pn, v, WontAccept p _) -> do+ putStrLn $ concat+ [ unPackageName pn+ , "-"+ , display v+ , ": Cannot accept the following packages"+ ]+ forM_ p $ \(x, y) -> putStrLn $ display x ++ " " ++ display y+ return False where- go newest fp = do- mdi <- loadPackage fp- di <-- case mdi of- Just di -> return di- Nothing -> error $ "Could not parse cabal file: " ++ fp- allGood <- case checkDeps newest di of- (pn, v, AllNewest) -> do- putStrLn $ concat- [ unPackageName pn- , "-"- , display v- , ": Can use newest versions of all dependencies"- ]- return True- (pn, v, WontAccept p _) -> do- putStrLn $ concat- [ unPackageName pn- , "-"- , display v- , ": Cannot accept the following packages"- ]- forM_ p $ \(x, y) -> putStrLn $ x ++ " " ++ y- return False- putStrLn ""- if allGood- then exitSuccess- else exitFailure+ overTrd :: (a -> b) -> (x, y, a) -> (x, y, b)+ overTrd f (x, y, a) = (x, y, f a) -unPackageName :: PackageName -> String-unPackageName (PackageName n) = n+ filterExcludes :: CheckDepsRes -> CheckDepsRes+ filterExcludes AllNewest = AllNewest+ filterExcludes (WontAccept p t) =+ case filter (\(n, _) -> display n `notElem` excludes) p of+ [] -> AllNewest+ p' -> WontAccept p' t +-- TODO+updateWithGhcPkg :: Newest -> IO Newest+updateWithGhcPkg newest = do+ output <- readProcess "ghc-pkg" ["dump"] ""+ ipis <- either (fail . show) (return . map snd) $+ traverse IPI.parseInstalledPackageInfo $+ map (encodeUtf8 . T.pack) $+ splitPkgs output+ return $ foldl' apply newest $ map toPackInfo ipis+ where+ apply :: Newest -> (PackageName, PackInfo) -> Newest+ apply m (k, v) = Map.insert k v m -usageExit :: IO a-usageExit = do- pname <- getProgName- putStrLn $ "\n"- ++ "Usage: " ++ pname ++ " pkgname.cabal\n\n"- ++ "Check the given cabal file's dependency list to make sure that it does not exclude\n"- ++ "the newest package available. Its probably worth running the 'cabal update' command\n"- ++ "immediately before running this program.\n"- exitSuccess+ toPackInfo :: IPI.InstalledPackageInfo -> (PackageName, PackInfo)+ toPackInfo ipi = (pkgName $ IPI.sourcePackageId ipi, pinfo) where+ pinfo = PackInfo+ { piVersion = pkgVersion $ IPI.sourcePackageId ipi+ , piEpoch = 0+ , piDesc = Nothing+ }++ -- copied from from Cabal+ splitPkgs :: String -> [String]+ splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines+ where+ -- Handle the case of there being no packages at all.+ checkEmpty [s] | all isSpace s = []+ checkEmpty ss = ss++ splitWith :: (a -> Bool) -> [a] -> [[a]]+ splitWith p xs = ys : case zs of+ [] -> []+ _:ws -> splitWith p ws+ where (ys,zs) = break p xs++run :: Bool -- ^ Check transitive dependencies+ -> Bool -- ^ Quiet -- only report packages that are not up to date+ -> Bool -- ^ ghc-pkg -- use ghc-pkg list to see whether there are even newer packages.+ -> Bool -- ^ preferred -- consider only preferred versions+ -> [String] -- ^ packages to exclude+ -> [FilePath] -- ^ .cabal filenames+ -> IO Bool+run deep quiet ghcpkg preferred excludes args = do+ newest' <- loadNewest preferred+ newest <- if ghcpkg then updateWithGhcPkg newest' else return newest'+ foldM (go newest) True args+ where+ go newest wasAllGood fp = do+ mdi <- loadPackage fp+ di <- case mdi of+ Just di -> return di+ Nothing -> error $ "Could not parse cabal file: " ++ fp+ allGood <- checkDepsCli quiet excludes checkDeps newest di+ depsGood <- if deep+ then do putStrLn $ "\nTransitive dependencies:"+ allM (checkDepsCli quiet excludes checkLibDeps newest) (deepLibDeps newest [di])+ else return True+ when (not (allGood && depsGood)) $ putStrLn ""+ return $ wasAllGood && allGood && depsGood++-- | Non short-circuiting monadic version of 'all'+-- Duh, pre-AMP code.+allM :: Monad m => (a -> m Bool) -> [a] -> m Bool+allM f xs = and `liftM` mapM f xs
− tools/packdeps-yesod.hs
@@ -1,441 +0,0 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings, MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell #-}-import Prelude hiding (writeFile)-import Yesod-import Yesod.AtomFeed-import Yesod.Feed-import Distribution.PackDeps-import Data.Maybe-import Data.List (sortBy)-import Data.Ord (comparing)-import Data.Time-import Distribution.Package-import Distribution.Text hiding (Text)-import Control.Arrow-import Distribution.Version (VersionRange, withinRange)-import qualified Data.Map as Map-import Data.Text (Text, pack, unpack, append)-import Text.Hamlet (shamlet)-import System.Environment (getArgs)-import Data.List (sort)-import Data.Version (Version)-import System.IO.Cautious (writeFileL)-import qualified Data.ByteString.Lazy as L-import Data.Aeson-import Data.Aeson.Types (Parser)-import Control.Monad (mzero)-import Control.Applicative ((<$>), (<*>))--data PD = PD Newest Reverses-mkYesod "PD" [parseRoutes|-/favicon.ico FaviconR GET-/ RootR GET-/feed FeedR GET-/feed/#Text Feed2R GET-/feeddeep/#Text Feed2DeepR GET-/feed/#Text/#Text/#Text/#Text Feed3R GET-/specific SpecificR GET-/feed/specific/#Text SpecificFeedR GET--/reverse ReverseListR GET-/reverse/#Text ReverseR GET-|]-instance Yesod PD where- approot = ApprootStatic ""--getFaviconR :: Handler ()-getFaviconR = sendFile "image/x-icon" "favicon.ico"--mainCassius :: CssUrl (Route PD)-mainCassius = [cassius|-body- font-family: Arial,Helvetica,sans-serif- width: 600px- margin: 2em auto- text-align: center-p- text-align: justify-h2- border-bottom: 2px solid #999-input[type=text]- width: 400px-#footer- margin-top: 15px- border-top: 1px dashed #999- padding-top: 10px-table- border-collapse: collapse- margin: 0 auto-th, td- border: 1px solid #333-form p- margin-top: 1em- text-align: center-|]--getRootR :: Handler RepHtml-getRootR = defaultLayout $ do- setTitle "Hackage dependency monitor"- addCassius mainCassius :: Widget -- just get rid of a warning by using Widget- [whamlet|-<h1>Hackage Dependency Monitor-<form action="@{FeedR}">- <input type="text" name="needle" required="" placeholder="Search string">- <input type="submit" value="Check">- <p>- <a href=@{ReverseListR}>Reverse Dependency List-<h2>What is this?-<p>It can often get tedious to keep your package dependencies up-to-date. This tool is meant to alleviate a lot of the burden. It will automatically determine when an upper bound on a package prevents the usage of a newer version. For example, if foo depends on bar >= 0.1 && < 0.2, and bar 0.2 exists, this tool will flag it.-<p>Enter a search string in the box above. It will find all packages containing that string in the package name, maintainer or author fields, and create an Atom feed for restrictive bounds. Simply add that URL to a news reader, and you're good to go!-<p>- \All of the code is - <a href="http://github.com/snoyberg/packdeps">available on Github- \. Additionally, there is a - <a href="http://hackage.haskell.org/package/packdeps">package on Hackage- \ with the code powering this site both as a library and as an executable, so you can test code which is not uploaded to the public Hackage server.-<div id="footer">- <a href="http://docs.yesodweb.com/">Powered by Yesod-|]--isDeep :: Handler Bool-isDeep = fmap (== Just "on") $ runInputGet $ iopt textField "deep"--getDeps :: Bool- -> String- -> Handler ([DescInfo], [((String, Version), ([(String, String)], UTCTime))])-getDeps deep needle = do- PD newest _ <- getYesod- let descs' = filterPackages needle newest- descs = if deep then deepDeps newest descs' else descs'- go (_, _, AllNewest) = Nothing- go (PackageName x, v, WontAccept y z) = Just ((x, v), (y, z))- deps = reverse $ sortBy (comparing $ snd . snd)- $ mapMaybe (go . checkDeps newest) descs- return (descs, deps)--instance RenderMessage PD FormMessage where- renderMessage _ _ = defaultFormMessage--getFeedR :: Handler RepHtml-getFeedR = do- needle <- runInputGet $ ireq textField "needle"- deep <- isDeep- (descs, deps) <- getDeps deep $ unpack needle- let title = "Newer dependencies for " ++ unpack needle- let deepR = (FeedR, [("needle", needle), ("deep", "on")])- defaultLayout $ do- setTitle $ toHtml title- addCassius [cassius|-body- font-family: Arial,Helvetica,sans-serif- width: 600px- margin: 2em auto-h1- text-align: center-p- text-align: justify-table- border-collapse: collapse-th, td- border: 1px solid #999- padding: 5px-h3- margin: 20px 0 5px 0-.packages- -webkit-column-count: 2- -moz-column-count: 2- column-count: 2-.packages a, .packages a:visited- text-decoration: none- color: blue-.packages a:hover- text-decoration: underline-|]- let feedR = (if deep then Feed2DeepR else Feed2R) needle- atomLink feedR title- [whamlet|-<h1>#{title}-<p>- \The following are the packages which have restrictive upper bounds. You can also #- <a href="@{feedR}">view this information as a news feed- \ so you can get automatic updates in your feed reader of choice.-$if null deps- <p>- <b>All upper bounds are non-restrictive.-$else- $forall d <- deps- <h3>#{fst (fst d)}-#{display (snd (fst d))}- <table>- $forall p <- fst (snd d)- <tr>- <th>#{fst p}- <td>#{snd p}-$if not deep- <p>- <a href=@?{deepR}>View outdated dependency for all ancestor packages too.-<h3>Packages checked-<div .packages>- <ol>- $forall name <- sort $ map diName descs- <li>- <a href="http://hackage.haskell.org/package/#{name}">#{name}-|]--getFeed2R :: Text -> Handler RepAtomRss-getFeed2R needle = do- (_, deps) <- getDeps False $ unpack needle- feed2Helper needle deps--getFeed2DeepR :: Text -> Handler RepAtomRss-getFeed2DeepR needle = do- (_, deps) <- getDeps True $ unpack needle- feed2Helper needle deps--feed2Helper :: Text- -> [((String, Version), ([(String, String)], UTCTime))]- -> Handler RepAtomRss-feed2Helper needle deps = do- now <- liftIO getCurrentTime- newsFeed Feed- { feedTitle = pack $ "Newer dependencies for " ++ unpack needle- , feedLinkSelf = Feed2R needle- , feedLinkHome = RootR- , feedUpdated = now- , feedEntries = map go' deps- , feedLanguage = "en"- , feedDescription = toHtml $ "Newer dependencies for " ++ unpack needle- }- where- go' ((name, version), (deps', time)) = FeedEntry- { feedEntryLink = Feed3R needle (pack name) (pack $ display version) (pack $ show time)- , feedEntryUpdated = time- , feedEntryTitle = pack $ "Outdated dependencies for " ++ name ++ " " ++ display version- , feedEntryContent = [shamlet|-<table border="1">- $forall d <- deps'- <tr>- <th>#{fst d}- <td>#{snd d}-|]- }--getFeed3R :: Text -> Text -> Text -> Text -> Handler ()-getFeed3R _ package _ _ =- redirect- $ "http://hackage.haskell.org/package/" `append` package--main :: IO ()-main = do- args <- getArgs- if args == ["--save-reverses"]- then do- newest <- loadNewest- writeFileL "reverses" $ encode (newest, getReverses newest)- else do- putStrLn "Loading reverses..."- Just (newest, reverses) <- fmap decode' $ L.readFile "reverses"- putStrLn "Done"- warpDebug 5005 $ PD newest reverses--instance ToJSON Version where- toJSON = toJSONShow-instance FromJSON Version where- parseJSON = parseJSONRead--toJSONShow :: Show a => a -> Value-toJSONShow = String . pack . show--parseJSONRead :: Read a => Value -> Parser a-parseJSONRead (String t) =- case reads $ unpack t of- (v, _):_ -> return v- _ -> mzero-parseJSON _ = mzero--instance ToJSON VersionRange where- toJSON = toJSONShow-instance FromJSON VersionRange where- parseJSON = parseJSONRead--instance ToJSON PackInfo where- toJSON (PackInfo a b c) = Data.Aeson.object- [ "version" .= a- , "desc" .= b- , "epoch" .= c- ]--instance FromJSON PackInfo where- parseJSON (Object v) = PackInfo- <$> v .: "version"- <*> v .: "desc"- <*> v .: "epoch"- parseJSON _ = mzero--instance ToJSON DescInfo where- toJSON (DescInfo a b c d) = Data.Aeson.object- [ "haystack" .= a- , "deps" .= b- , "package" .= c- , "synopsis" .= d- ]--instance FromJSON DescInfo where- parseJSON (Object v) = DescInfo- <$> v .: "haystack"- <*> v .: "deps"- <*> v .: "package"- <*> v .: "synopsis"- parseJSON _ = mzero--instance ToJSON PackageIdentifier where- toJSON = toJSONShow-instance FromJSON PackageIdentifier where- parseJSON = parseJSONRead--instance ToJSON Dependency where- toJSON = toJSONShow-instance FromJSON Dependency where- parseJSON = parseJSONRead--getSpecificR :: Handler RepHtml-getSpecificR = do- packages' <- lookupGetParams "package"- PD newest _ <- getYesod- let packages = map (id &&& flip getPackage newest) $ map unpack packages'- let title = "Newer dependencies for your Hackage packages"- let checkDeps' x =- case checkDeps newest x of- (_, _, AllNewest) -> Nothing- (_, v, WontAccept cd _) -> Just (v, cd)- defaultLayout $ do- setTitle $ toHtml title- addCassius [cassius|-body- font-family: Arial,Helvetica,sans-serif- width: 600px- margin: 2em auto-h1- text-align: center-p- text-align: justify-table- border-collapse: collapse-th, td- border: 1px solid #999- padding: 5px-h3- margin: 20px 0 5px 0-|]- let feedR = SpecificFeedR $ pack $ unwords $ map unpack packages'- atomLink feedR title- [whamlet|-<h1>#{title}-<p>- The following are the packages which have restrictive upper bounds. You can also #- <a href="@{feedR}">view this information as a news feed- \ so you can get automatic updates in your feed reader of choice.-$forall p <- packages- $maybe descinfo <- snd p- $maybe x <- checkDeps' descinfo- <h3>#{fst p}-#{display (fst x)}- <table>- $forall p <- snd x- <tr>- <th>#{fst p}- <td>#{snd p}- $nothing- <h3>#{fst p} up to date- $nothing- <p>Invalid package name: #{fst p}-|]--getSpecificFeedR :: Text -> Handler RepAtomRss-getSpecificFeedR packages' = do- PD newest _ <- getYesod- let descs = mapMaybe (flip getPackage newest) $ words $ unpack packages'- let go (_, _, AllNewest) = Nothing- go (PackageName x, v, WontAccept y z) = Just ((x, v), (y, z))- deps = reverse $ sortBy (comparing $ snd . snd)- $ mapMaybe (go . checkDeps newest) descs- now <- liftIO getCurrentTime- newsFeed Feed- { feedTitle = "Newer dependencies for Hackage packages"- , feedLinkSelf = SpecificFeedR packages'- , feedLinkHome = RootR- , feedUpdated = now- , feedEntries = map go' deps- , feedLanguage = "en"- , feedDescription = "Newer dependencies for Hackage packages"- }- where- go' ((name, version), (deps, time)) = FeedEntry- { feedEntryLink = Feed3R packages' (pack name) (pack $ display version) (pack $ show time)- , feedEntryUpdated = time- , feedEntryTitle = pack $ "Outdated dependencies for " ++ name ++ " " ++ display version- , feedEntryContent = [shamlet|-<table border="1">- $forall d <- deps- <tr>- <th>#{fst d}- <td>#{snd d}-|]- }--getReverseListR :: Handler RepHtml-getReverseListR = do- PD _ reverse' <- getYesod- defaultLayout $ do- setTitle "Reverse Dependencies"- addCassius mainCassius- addHamlet [hamlet|-<h1>Reverse Dependencies-<p>Please choose a package below to view its reverse dependencies: those packages that depend upon it. This listing will also tell you which packages are incompatible with the current version of the package.-<table- <tr- <th>Package- <th>Total Dependencies- <th>Total Outdated Dependencies- $forall p <- Map.toList reverse'- <tr>- <td- <a href=@{ReverseR $ pack $ fst p}>#{fst p}- <td>#{show $ length $ snd $ snd p}- $maybe o <- getOutdated $ snd p- <td style="color:#900">#{o}- $nothing- <td>0-|]- where- getOutdated (version, pairs) =- case filter (not . withinRange version . snd) pairs of- [] -> Nothing- ps -> Just $ show $ length ps--getReverseR :: Text -> Handler RepHtml-getReverseR dep = do- PD _ reverse' <- getYesod- (version, rels) <- maybe notFound return $ Map.lookup (unpack dep) reverse'- defaultLayout $ do- setTitle [shamlet|Reverse dependencies for #{dep}|]- addCassius mainCassius- addHamlet [hamlet|-<h1><a href="http://hackage.haskell.org/package/#{dep}">#{dep}</a> #{display version}-<table>- <tr>- <th>#{show $ length rels} Reverse #{plural (length rels) "dep" "deps"}- <th>Accepted versions- $forall rel <- rels- <tr>- $if Map.member (fst rel) reverse'- <td><a href=@{ReverseR $ pack $ fst rel}>#{fst rel}- $else- <td>#{fst rel}- $if withinRange version (snd rel)- <td><a href="http://hackage.haskell.org/package/#{fst rel}">#{display (snd rel)}- $else- <td style="background-color:#fbb"><a href="http://hackage.haskell.org/package/#{fst rel}">#{display (snd rel)}-|]- where- plural :: Int -> String -> String -> String- plural 1 s _ = s- plural _ _ pl = pl