diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for stackage-query +## 0.2.0 -- 2019-05-08 +- download yaml files directly from github instead of huge git repos + (http-directory looks in stackage.org and then curl downloads raw github yaml) +- use simple-cmd-args + ## 0.1.3 -- 2018-11-15 - bundle Stackage.Types from old stackage-types package - updates to build with Cabal-2 etc diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,23 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,3)) +#else +import Control.Exception (bracket) +#endif import Control.Monad +import qualified Data.ByteString.Char8 as B import Data.Char (isDigit) import Data.List import qualified Data.Map.Strict (assocs, keys, lookup) import Data.Maybe -#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,11,1)) -#else -import Data.Monoid -#endif +import Data.Semigroup ((<>)) import qualified Data.Set as Set import qualified Data.Text as T import Data.Version import Options.Applicative import System.Directory -import System.Exit import System.FilePath -import System.Process (rawSystem, readProcess) +import System.IO (hPutStrLn, stderr) +import System.Posix.IO (stdInput) +import System.Posix.Terminal (queryTerminal) import Text.ParserCombinators.ReadP (readP_to_S) import Stackage.Types hiding (unPackageName) @@ -25,21 +28,21 @@ import Data.Yaml hiding (Parser) import Distribution.Package (PackageName, unPackageName) import Distribution.Text (disp) - -import Paths_stackage_query (version) +import Network.HTTP.Directory (httpManager, httpRedirect) -newtype Args = Args Command +import SimpleCmd (cmd_) +import SimpleCmdArgs -newtype ConsumerOption = ConsumerOption {threshold :: Int} +import Paths_stackage_query (version) data Snapshot = LatestNightly | LatestLTS | NightlySnap String | LtsSnap String | LtsMajor String instance Show Snapshot where show LatestNightly = "nightly" show LatestLTS = "lts" - show (NightlySnap date) = "nightly-" ++ date - show (LtsSnap ver) = "lts-" ++ ver - show (LtsMajor ver) = "lts-" ++ ver + show (NightlySnap date) = "nightly-" <> date + show (LtsSnap ver) = "lts-" <> ver + show (LtsMajor ver) = "lts-" <> ver instance Read Snapshot where readsPrec _ "nightly" = [(LatestNightly,"")] @@ -61,124 +64,59 @@ show LTS = "lts-haskell" show Nightly = "stackage-nightly" -instance Read Project where - readsPrec _ "lts" = [(LTS,"")] - readsPrec _ "nightly" = [(Nightly,"")] - readsPrec _ _ = [] - type Pkg = String -data Command = Config Snapshot - | Ghc Snapshot - | Core Snapshot - | Tools Snapshot (Maybe Pkg) - | Packages Snapshot - | Consumers ConsumerOption Snapshot - | Package Snapshot Pkg - | Users Snapshot Pkg - | Github Snapshot Pkg - | Constraints Snapshot Pkg - | Dependencies Snapshot Pkg - | Executables Snapshot Pkg - | Modules Snapshot Pkg - | Latest Project - -consumeParser :: Parser ConsumerOption -consumeParser = ConsumerOption <$> option auto - (long "minimum" <> short 'm' <> metavar "THRESHOLD" <> value 5 <> help "Show packages with at least THRESHOLD consumers (default 5)") +consumeParser :: Parser Int +consumeParser = + optionalWith auto 'm' "minimum" "THRESHOLD" "Show packages with at least THRESHOLD consumers (default 5)" 5 -parsePkg :: Pkg -> Parser Pkg -parsePkg lbl = strArgument $ metavar lbl +parsePkg :: Parser Pkg +parsePkg = strArg "PKG" parseSnap :: Parser Snapshot parseSnap = argument auto $ metavar "SNAP" -parseProject :: Parser Project -parseProject = argument auto $ metavar "PROJECT" - -commandParser :: Parser Command -commandParser = - subparser $ - command "package" (info (Package <$> parseSnap <*> parsePkg "PKG") - (progDesc "Show version of PKG in SNAP")) - <> - command "users" (info (Users <$> parseSnap <*> parsePkg "PKG") - (progDesc "Revdeps for PKG in SNAP")) - <> - command "github" (info (Github <$> parseSnap <*> parsePkg "PKG") - (progDesc "Stackage owners for PKG in SNAP")) - <> - command "constraints" (info (Constraints <$> parseSnap <*> parsePkg "PKG") - (progDesc "Stackage constraints for PKG in SNAP")) - <> - command "dependencies" (info (Dependencies <$> parseSnap <*> parsePkg "PKG") - (progDesc "Dependencies for PKG in SNAP")) - <> - command "executables" (info (Executables <$> parseSnap <*> parsePkg "PKG") - (progDesc "Executables of PKG in SNAP")) - <> - command "modules" (info (Modules <$> parseSnap <*> parsePkg "PKG") - (progDesc "Modules of PKG in SNAP")) - <> - command "latest" (info (Latest <$> parseProject) - (progDesc "Latest snap for PROJECT (nightly or lts)")) - <> - command "ghc" (info (Ghc <$> parseSnap) - (progDesc "GHC version for SNAP")) - <> - command "core" (info (Core <$> parseSnap) - (progDesc "GHC core libraries for SNAP")) - <> - command "tools" (info (Tools <$> parseSnap <*> optional (parsePkg "PKG")) - (progDesc "Tools for SNAP")) - <> - command "packages" (info (Packages <$> parseSnap) - (progDesc "All packages in SNAP")) - <> - command "consumers" (info (Consumers <$> consumeParser <*> parseSnap) - (progDesc "No of users of packages in SNAP")) - <> - command "config" (info (Config <$> parseSnap) - (progDesc "Download cabal.config file for SNAP")) - -argsParser :: Parser Args -argsParser = Args <$> commandParser - main :: IO () -main = do - cmd <- customExecParser (prefs showHelpOnEmpty) - (info (helper <*> versionOption <*> argsParser) $ progDesc "Stackage query tool") - run cmd - where - run (Args cmd) = - case cmd of - Config s -> stackageConfig s - Ghc s -> buildplanGHC s - Core s -> buildplanCore s - Tools s mpkg -> buildplanTools s mpkg - Packages s -> buildplanPackages s - Consumers opts s -> buildplanConsumers opts s - Package s pkg -> buildplanPackage s pkg - Users s pkgs -> buildplanUsers s pkgs - Github s pkg -> buildplanGithub s pkg - Constraints s pkg -> buildplanConstraints s pkg - Dependencies s pkg -> buildplanDependencies s pkg - Executables s pkg -> buildplanExecutables s pkg - Modules s pkg -> buildplanModules s pkg - Latest prj -> buildplanLatest prj - - versionOption = - infoOption - (showVersion version) - (long "version" <> help "Show version") +main = + simpleCmdArgs (Just version) "Stackage query tool" "" $ + subcommands + [ Subcommand "package" "Show version of PKG in SNAP" $ + buildplanPackage <$> parseSnap <*> parsePkg + , Subcommand "users" "Revdeps for PKG in SNAP" $ + buildplanUsers <$> parseSnap <*> parsePkg + , Subcommand "github" "Stackage owners for PKG in SNAP" $ + buildplanGithub <$> parseSnap <*> parsePkg + , Subcommand "constraints" "Stackage constraints for PKG in SNAP" $ + buildplanConstraints <$> parseSnap <*> parsePkg + , Subcommand "dependencies" "Dependencies for PKG in SNAP" $ + buildplanDependencies <$> parseSnap <*> parsePkg + , Subcommand "executables" "Executables of PKG in SNAP" $ + buildplanExecutables <$> parseSnap <*> parsePkg + , Subcommand "modules" "Modules of PKG in SNAP" $ + buildplanModules <$> parseSnap <*> parsePkg + , Subcommand "latest" "Latest snap for PROJECT (nightly or lts)" $ + buildplanLatest <$> parseSnap + , Subcommand "ghc" "GHC version for SNAP" $ + buildplanGHC <$> parseSnap + , Subcommand "core" "GHC core libraries for SNAP" $ + buildplanCore <$> parseSnap + , Subcommand "tools" "Tools for SNAP" $ + buildplanTools <$> parseSnap <*> optional parsePkg + , Subcommand "packages" "All packages in SNAP" $ + buildplanPackages <$> parseSnap + , Subcommand "consumers" "No of users of packages in SNAP" $ + buildplanConsumers <$> consumeParser <*> parseSnap + , Subcommand "config" "Download cabal.config file for SNAP" $ + stackageConfig <$> parseSnap + ] topurl :: String topurl = "https://www.stackage.org/" stackageConfig :: Snapshot -> IO () stackageConfig snap = do - let url = topurl ++ show snap "cabal.config" - system_ "curl" ["-L", "-O", url] + let url = topurl show snap "cabal.config" + cmd_ "curl" ["-L", "-O", url] getConfigDir :: IO FilePath getConfigDir = do @@ -192,19 +130,18 @@ configDir <- getConfigDir let projectDir = configDir show project haveProj <- doesDirectoryExist projectDir - unless haveProj $ cloneProject configDir project + unless haveProj $ createDirectoryIfMissing False projectDir return projectDir -findBuildPlanYaml :: Snapshot -> IO FilePath -findBuildPlanYaml snap = do - dir <- getProjectDir $ snapProject snap - updateProject False dir - findSnap dir snap - getBuildPlan :: Snapshot -> IO BuildPlan getBuildPlan snap = do - ebp <- findBuildPlanYaml snap >>= decodeFileEither + ebp <- findBuildPlanYaml >>= decodeFileEither either (error . prettyPrintParseException) return ebp + where + findBuildPlanYaml :: IO FilePath + findBuildPlanYaml = do + dir <- getProjectDir $ snapProject snap + findSnap dir snap snapProject :: Snapshot -> Project snapProject LatestLTS = LTS @@ -216,15 +153,32 @@ findSnap dir snap = do fs <- sortProject . filter (show snap `isPrefixOf`) <$> getDirectoryContents dir if null fs - then error $ "Snap " ++ show snap ++ " not found" - else return (dir last fs) + then downloadLatest + else return $ dir last fs where sortProject :: [String] -> [String] sortProject = if snapProject snap == Nightly then sort - else map ((\v -> "lts-" ++ v ++ ".yaml") . showVersion) . sort . map (readVersion . takeBaseName . removePrefix "lts-") + else map ((\v -> "lts-" <> v <.> "yaml") . showVersion) . sort . map (readVersion . takeBaseName . removePrefix "lts-") + downloadLatest :: IO FilePath + downloadLatest = do + latest <- latestSnap snap + downloadSnap latest + return $ dir show latest <.> "yaml" + + downloadSnap :: Snapshot -> IO () + downloadSnap snp = do + let proj = snapProject snp + withCurrentDirectory dir $ do + tty <- queryTerminal stdInput + let silent = if tty then ["-#"] else ["-s", "-S"] + yaml = show snp <.> "yaml" + url = "https://raw.githubusercontent.com/commercialhaskell" show proj "master" yaml + hPutStrLn stderr $ "Downloading " <> yaml + cmd_ "curl" $ silent ++ ["-O", url] + readVersion :: String -> Version readVersion s = let vp = readP_to_S parseVersion s in @@ -233,48 +187,7 @@ (ver,"") -> ver _ -> giveup where - giveup = error $ "readVersion: failed to parse " ++ s - -system :: String -> [String] -> IO String -system c args = removeTrailingNewline <$> readProcess c args "" - where - removeTrailingNewline :: String -> String - removeTrailingNewline "" = "" - removeTrailingNewline cs = - if last cs == '\n' - then init cs - else cs - -system_ :: String -> [String] -> IO () -system_ c args = do - ret <- rawSystem c args - case ret of - ExitSuccess -> return () - ExitFailure n -> error $ "\"" ++ unwords (c:args) ++ "\" failed with exit code " ++ show n - -git :: FilePath -> String -> [String] -> IO String -git dir cmd args = - system "git" $ ["-C", dir] ++ cmd:args - -git_ :: FilePath -> String -> [String] -> IO () -git_ dir cmd args = - system_ "git" $ ["-C", dir] ++ cmd:args - -cloneProject :: FilePath -> Project -> IO () -cloneProject dir proj = do - let url = "git://github.com/fpco" show proj - putStrLn $ "Cloning " ++ url - git_ dir "clone" [url] - -updateProject :: Bool -> FilePath -> IO () -updateProject verbose dir = do - msg <- shortLog - _ <- git dir "pull" ["-q"] - msg' <- shortLog - when (verbose && msg /= msg') $ putStrLn $ msg ++ " -> " ++ msg' - where - shortLog = - removePrefix "Checking in " . unwords . tail . words <$> git dir "log" ["--oneline", "-1"] + giveup = error $ "readVersion: failed to parse " <> s buildplanGHC :: Snapshot -> IO () buildplanGHC snap = do @@ -283,7 +196,7 @@ putStrLn $ (showVersion . siGhcVersion) si showPkgVer :: (PackageName, Version) -> String -showPkgVer (p,v) = unPackageName p ++ " " ++ showVersion v +showPkgVer (p,v) = unPackageName p <> " " <> showVersion v buildplanCore :: Snapshot -> IO () buildplanCore snap = do @@ -301,16 +214,16 @@ bp <- getBuildPlan snap traverse_ (putStrLn . showPkgVer) $ Data.Map.Strict.assocs $ ppVersion <$> bpPackages bp -buildplanConsumers :: ConsumerOption -> Snapshot -> IO () -buildplanConsumers opts snap = do +buildplanConsumers :: Int -> Snapshot -> IO () +buildplanConsumers threshold snap = do bp <- getBuildPlan snap traverse_ putPkgConsumption $ Data.Map.Strict.assocs $ ppUsers <$> bpPackages bp where putPkgConsumption :: (PackageName, Set.Set PackageName) -> IO () putPkgConsumption (p, users) = do let n = length users - when (n >= threshold opts) $ - putStrLn $ show n ++ " " ++ unPackageName p + when (n >= threshold) $ + putStrLn $ show n <> " " <> unPackageName p evalPackageBuildPlan :: Snapshot -> Pkg -> (PackagePlan -> String) -> IO () evalPackageBuildPlan snap pkg expr = do @@ -330,14 +243,15 @@ buildplanGithub snap pkg = evalPackageBuildPlan snap pkg (unwords . Set.elems . Set.map T.unpack . ppGithubPings) -projectToSnap :: Project -> Snapshot -projectToSnap Nightly = LatestNightly -projectToSnap LTS = LatestLTS +latestSnap :: Snapshot -> IO Snapshot +latestSnap snap = do + mgr <- httpManager + latest <- httpRedirect mgr $ topurl show snap + return $ maybe snap (read . B.unpack . B.tail) latest -buildplanLatest :: Project -> IO () -buildplanLatest prj = do - latest <- findBuildPlanYaml (projectToSnap prj) - putStrLn $ takeBaseName latest +buildplanLatest :: Snapshot -> IO () +buildplanLatest = + latestSnap >=> print buildplanConstraints :: Snapshot -> Pkg -> IO () buildplanConstraints snap pkg = @@ -359,3 +273,11 @@ buildplanModules snap pkg = evalPackageBuildPlan snap pkg (unlines . map T.unpack . Set.toList. sdModules . ppDesc) +#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,3)) +#else +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory dir action = + bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do + setCurrentDirectory dir + action +#endif diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +[![Build Status](https://travis-ci.org/juhp/stackage-query.png)](https://travis-ci.org/juhp/stackage-query) +[![Hackage](http://img.shields.io/hackage/v/stackage-query.png)](http://hackage.haskell.org/package/stackage-query) +[![Stackage LTS](http://stackage.org/package/stackage-query/badge/lts)](http://stackage.org/lts/package/stackage-query) +[![Stackage Nightly](http://stackage.org/package/stackage-query/badge/nightly)](http://stackage.org/nightly/package/stackage-query) + +# Stackage-Query + +Small tool that queries package metadata from Stackage snapshots +using the yaml files from stackage-nightly and lts-haskell. + +Example usage: + +``` +$ stackage package lts pandoc +2.5 +$ stackage core lts-12 + +$ stackage packages lts-13.20 | wc -l +2322 +$ stackage consumers lts-12 --minimum 500 +867 text +$ stackage users nightly pandoc +pandoc pandoc-citeproc pandoc-csv2table pandoc-pyplot +$ stackage latest nightly +nightly-2019-05-07 +``` diff --git a/Stackage/Types.hs b/Stackage/Types.hs --- a/Stackage/Types.hs +++ b/Stackage/Types.hs @@ -30,7 +30,7 @@ , intersectVersionRanges ) where -import Control.Applicative ((<$>), (<*>), (<|>)) +import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) import Control.Exception (Exception) import Control.Monad.Catch (MonadThrow, throwM) @@ -42,6 +42,10 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0)) +#else +import Data.Monoid (Monoid) +#endif import Data.Semigroup (Semigroup, (<>)) import Data.Set (Set) import qualified Data.Set as Set diff --git a/stackage-query.cabal b/stackage-query.cabal --- a/stackage-query.cabal +++ b/stackage-query.cabal @@ -1,7 +1,7 @@ name: stackage-query -version: 0.1.3 -synopsis: Stackage package query -description: Tool to query package metadata in Stackage +version: 0.2.0 +synopsis: Tool for querying Stackage +description: A commandline tool to query metadata of Stackage packages license: MIT license-file: LICENSE homepage: https://github.com/juhp/stackage-query @@ -11,9 +11,10 @@ copyright: 2017 Jens Petersen category: Distribution build-type: Simple -extra-source-files: ChangeLog.md +extra-source-files: ChangeLog.md, README.md cabal-version: >=1.10 -tested-with: GHC == 7.10.3, GHC == 8.0.2 +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, + GHC == 8.6.5 source-repository head type: git @@ -24,17 +25,22 @@ build-depends: base >= 4.7 && < 5, Cabal >= 1.22, aeson, + bytestring, containers, directory, exceptions >= 0.6, hashable, + http-directory >= 0.1.2, filepath, optparse-applicative >= 0.13, process, safe, semigroups, + simple-cmd, + simple-cmd-args >= 0.1.1, text, time, + unix, unordered-containers, vector, yaml