stackage-query (empty) → 0.1.0
raw patch · 5 files changed
+382/−0 lines, 5 filesdep +Cabaldep +basedep +containerssetup-changed
Dependencies added: Cabal, base, containers, directory, filepath, optparse-applicative, process, stackage-types, text, yaml
Files
- ChangeLog.md +5/−0
- LICENSE +20/−0
- Main.hs +320/−0
- Setup.hs +2/−0
- stackage-query.cabal +35/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for stackage-query++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 Jens Petersen++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Main.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad+import Data.Char (isDigit)+import Data.List+import qualified Data.Map.Strict (assocs, lookup)+import Data.Maybe+import Data.Monoid+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 Text.ParserCombinators.ReadP (readP_to_S)++import Stackage.Types hiding (unPackageName)+import Data.Foldable (traverse_)+import Data.Yaml hiding (Parser)+import Distribution.Package (PackageName(..), unPackageName)++newtype Args = Args Command++newtype ConsumerOption = ConsumerOption {threshold :: Int}++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++instance Read Snapshot where+ readsPrec _ "nightly" = [(LatestNightly,"")]+ readsPrec _ "lts" = [(LatestLTS,"")]+ readsPrec _ input | "nightly-" `isPrefixOf` input =+ let (date,rest) = span (\ c -> isDigit c || c == '-') $ removePrefix "nightly-" input in+ [(NightlySnap date,rest)]+ readsPrec _ input | "lts-" `isPrefixOf` input =+ let (ver,rest) = span (\ c -> isDigit c || c == '.') $ removePrefix "lts-" input in+ [(if '.' `elem` ver then LtsSnap ver else LtsMajor ver,rest)]+ readsPrec _ _ = []++removePrefix :: String -> String-> String+removePrefix pref orig = fromMaybe orig (stripPrefix pref orig)++data Project = LTS | Nightly deriving (Eq)++instance Show Project where+ show LTS = "lts-haskell"+ show Nightly = "stackage-nightly"++instance Read Project where+ readsPrec _ "lts" = [(LTS,"")]+ readsPrec _ "nightly" = [(Nightly,"")]+ readsPrec _ _ = []++data Command = Config Snapshot+ | Ghc Snapshot+ | Core Snapshot+ | Tools Snapshot+ | Packages Snapshot+ | Consumers ConsumerOption Snapshot+ | Package Snapshot String+ | Users Snapshot String+ | Github Snapshot String+ | Latest Project+ | Update 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)")++parseString :: String -> Parser String+parseString lbl = strArgument $ metavar lbl++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 <*> parseString "PKG")+ (progDesc "Show version of PKG in SNAP"))+ <>+ command "users" (info (Users <$> parseSnap <*> parseString "PKG")+ (progDesc "Revdeps for PKG in SNAP"))+ <>+ command "github" (info (Github <$> parseSnap <*> parseString "PKG")+ (progDesc "Stackage owners for PKG in SNAP"))+ <>+ command "latest" (info (Latest <$> parseProject)+ (progDesc "Latest snap for PROJECT (nightly or lts)"))+ <>+ command "update" (info (Update <$> parseProject)+ (progDesc "git update 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)+ (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 <*> 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 -> buildplanTools s+ Packages s -> buildplanPackages s+ Consumers opts s -> buildplanConsumers opts s+ Package s pkg -> buildplanPackage s pkg+ Users s pkg -> buildplanUsers s pkg+ Github s pkg -> buildplanGithub s pkg+ Latest prj -> buildplanLatest prj+ Update prj -> buildplanUpdate prj++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]++getConfigDir :: IO FilePath+getConfigDir = do+ home <- getHomeDirectory+ let confdir = home </> ".stackage-query"+ createDirectoryIfMissing False confdir+ return confdir++getProjectDir :: Project -> IO FilePath+getProjectDir project = do+ configDir <- getConfigDir+ let projectDir = configDir </> show project+ haveProj <- doesDirectoryExist projectDir+ unless haveProj $ cloneProject configDir project+ return projectDir++findBuildPlanYaml :: Snapshot -> IO FilePath+findBuildPlanYaml snap = do+ projectDir <- getProjectDir $ snapProject snap+ findSnap True projectDir snap++getBuildPlan :: Snapshot -> IO BuildPlan+getBuildPlan snap = do+ ebp <- findBuildPlanYaml snap >>= decodeFileEither+ either (error . prettyPrintParseException) return ebp++snapProject :: Snapshot -> Project+snapProject LatestLTS = LTS+snapProject (LtsSnap _) = LTS+snapProject (LtsMajor _) = LTS+snapProject _ = Nightly++findSnap :: Bool -> FilePath -> Snapshot -> IO FilePath+findSnap update dir snap = do+ fs <- sortProject . filter (show snap `isPrefixOf`) <$> getDirectoryContents dir+ if null fs+ then+ if update+ then do+ updateProject dir+ findSnap False dir snap+ else+ error $ "Snap " ++ show snap ++ " not found"+ 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-")++readVersion :: String -> Version+readVersion s =+ let vp = readP_to_S parseVersion s in+ if null vp then giveup+ else case last vp of+ (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 :: FilePath -> IO ()+updateProject dir = do+ msg <- shortLog+ _ <- git dir "pull" []+ msg' <- shortLog+ when (msg /= msg') $ putStrLn $ msg ++ " -> " ++ msg'+ where+ shortLog =+ removePrefix "Checking in " . unwords . tail . words <$> git dir "log" ["--oneline", "-1"]++buildplanGHC :: Snapshot -> IO ()+buildplanGHC snap = do+ bp <- getBuildPlan snap+ let si = bpSystemInfo bp+ putStrLn $ (showVersion . siGhcVersion) si++showPkgVer :: (PackageName, Version) -> String+showPkgVer (p,v) = unPackageName p ++ " " ++ showVersion v++buildplanCore :: Snapshot -> IO ()+buildplanCore snap = do+ bp <- getBuildPlan snap+ let si = bpSystemInfo bp+ traverse_ (putStrLn . showPkgVer) $ (Data.Map.Strict.assocs . siCorePackages) si++buildplanTools :: Snapshot -> IO ()+buildplanTools snap = do+ bp <- getBuildPlan snap+ traverse_ (putStrLn . showPkgVer) $ bpTools bp++buildplanPackages :: Snapshot -> IO ()+buildplanPackages snap = do+ bp <- getBuildPlan snap+ traverse_ (putStrLn . showPkgVer) $ Data.Map.Strict.assocs $ ppVersion <$> bpPackages bp++buildplanConsumers :: ConsumerOption -> Snapshot -> IO ()+buildplanConsumers opts 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++evalPackageBuildPlan :: Snapshot -> String -> (PackagePlan -> String) -> IO ()+evalPackageBuildPlan snap pkg expr = do+ bp <- getBuildPlan snap+ let mpkgplan = Data.Map.Strict.lookup (PackageName pkg) $ bpPackages bp+ putStrLn $ maybe "Package not found" expr mpkgplan++buildplanPackage :: Snapshot -> String -> IO ()+buildplanPackage snap pkg =+ evalPackageBuildPlan snap pkg (showVersion . ppVersion)++buildplanUsers :: Snapshot -> String -> IO ()+buildplanUsers snap pkg =+ evalPackageBuildPlan snap pkg (unwords . Set.elems . Set.map unPackageName . ppUsers)++buildplanGithub :: Snapshot -> String -> IO ()+buildplanGithub snap pkg =+ evalPackageBuildPlan snap pkg (unwords . Set.elems . Set.map T.unpack . ppGithubPings)++projectToSnap :: Project -> Snapshot+projectToSnap Nightly = LatestNightly+projectToSnap LTS = LatestLTS++buildplanLatest :: Project -> IO ()+buildplanLatest prj = do+ latest <- takeBaseName <$> findBuildPlanYaml (projectToSnap prj)+ putStrLn latest++buildplanUpdate :: Project -> IO ()+buildplanUpdate project =+ getProjectDir project >>= updateProject
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ stackage-query.cabal view
@@ -0,0 +1,35 @@+name: stackage-query+version: 0.1.0+synopsis: Stackage package query+description: Tool to query package versions in Stackage+license: MIT+license-file: LICENSE+homepage: https://github.com/juhp/stackage-query+bug-reports: https://github.com/juhp/stackage-query/issues+author: Jens Petersen+maintainer: juhpetersen@gmail.com+copyright: Jens Petersen+category: Distribution+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10+tested-with: GHC == 7.10.3, GHC == 8.0.2++source-repository head+ type: git+ location: https://github.com/juhp/stackage-query++executable stackage+ main-is: Main.hs+ build-depends: base >= 4.7 && < 5,+ Cabal >= 1.22,+ containers,+ directory,+ filepath,+ optparse-applicative >= 0.13,+ process,+ stackage-types,+ text,+ yaml+ GHC-options: -fwarn-missing-signatures -Wall+ default-language: Haskell2010