├── .nix └── mk-source.nix ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── app └── Main.hs ├── default.nix ├── pump.cabal ├── shell.nix └── src ├── Commands.hs ├── Fetch.hs ├── FileSystem.hs ├── PackDeps.hs ├── PackDeps └── Types.hs ├── Pump.hs └── Types.hs /.nix/mk-source.nix: -------------------------------------------------------------------------------- 1 | { lib }: 2 | 3 | with lib; 4 | 5 | src: 6 | 7 | cleanSourceWith { 8 | filter = name: type: 9 | let baseName = baseNameOf (builtins.toString name); 10 | in cleanSourceFilter name type && ! ( 11 | hasPrefix "cabal.project" baseName 12 | || hasPrefix "ghcid.txt" baseName 13 | || hasPrefix "hie.yaml" baseName 14 | || hasPrefix "Makefile" baseName 15 | || hasSuffix ".cabal" baseName 16 | || hasSuffix ".sublime-project" baseName 17 | || hasSuffix ".md" baseName 18 | || (type == "directory" && baseName == "scripts") 19 | || (type == "directory" && baseName == "API-Spec") 20 | || (type == "directory" && baseName == "docs") 21 | || (type == "directory" && baseName == "benchmark") 22 | || (type == "directory" && hasPrefix "dist" baseName) 23 | || (type == "binary") 24 | ); 25 | inherit src; 26 | } 27 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for pump 2 | 3 | ## 0.1 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The following license covers this documentation, and the source code, except 2 | where otherwise indicated. 3 | 4 | Copyright 2012, Michael Snoyman. All rights reserved. 5 | Copyright 2020, chessai. All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR 18 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 19 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO 20 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, 21 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 22 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, 23 | OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 24 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 25 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 26 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | configure: 2 | cabal configure 3 | 4 | build: 5 | cabal build 6 | 7 | clean: 8 | cabal clean 9 | 10 | ghci: 11 | cabal repl 12 | 13 | ghcid: 14 | ghcid -c "cabal repl" 15 | 16 | sdist: 17 | cabal sdist 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # pump (the brakes) 2 | 3 | Given a haskell package, construct a build matrix of all its (valid) reverse dependencies. This is useful if you want to estimate downstream breakage introduced by an API change, e.g. by building all of the relevant packages against the patched haskell package. 4 | 5 | A lot of the code for handling the hackage index/computing reverse dependencies therefrom was lifted from https://github.com/snoyberg/packdeps. 6 | 7 | ## Example 8 | 9 | Building the 20 most popular reverse dependencies against it in a build matrix. 10 | 11 | ### Download the package index 12 | ```bash 13 | $ pump download -o index 14 | ``` 15 | 16 | ### Print out the 20 most popular dependencies of array (just for reference) 17 | ```bash 18 | $ pump top -i index -p array -n 20 19 | containers 20 | text 21 | deepseq 22 | lens 23 | binary 24 | stm 25 | attoparsec 26 | http-types 27 | Cabal 28 | http-client 29 | cereal 30 | warp 31 | quickcheck-instances 32 | ghc 33 | HTTP 34 | haskell98 35 | parallel 36 | haskell-src-exts 37 | MissingH 38 | gtk 39 | ``` 40 | 41 | ### Generate the build matrix 42 | ```bash 43 | $ pump matrix -i index -p array -o matrix.json -n 20 44 | ``` 45 | 46 | ### Realise the build matrix and generate a report 47 | ``` 48 | $ pump realise -m matrix.json -o report.json 49 | ``` 50 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Pump 4 | 5 | main :: IO () 6 | main = Pump.main 7 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} 2 | , ... 3 | }: 4 | 5 | rec { 6 | inherit pkgs; 7 | 8 | hsPkgs = pkgs.haskellPackages; 9 | 10 | mkSource = import ./.nix/mk-source.nix { inherit (pkgs) lib; }; 11 | 12 | pump = hsPkgs.callCabal2nix "pump" ./. {}; #(mkSource ./.) {}; 13 | } 14 | -------------------------------------------------------------------------------- /pump.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | pump 4 | version: 5 | 0.1 6 | synopsis: 7 | reverse dependencies build matrix 8 | -- description: 9 | homepage: 10 | https://github.com/chessai/pump 11 | -- bug-reports: 12 | license: 13 | MIT 14 | license-file: 15 | LICENSE 16 | author: 17 | chessai 18 | Michael Snoyman 19 | maintainer: 20 | chessai 21 | -- copyright: 22 | category: 23 | Development 24 | extra-source-files: 25 | CHANGELOG.md 26 | 27 | library 28 | exposed-modules: 29 | Pump 30 | other-modules: 31 | Commands 32 | Fetch 33 | FileSystem 34 | PackDeps 35 | PackDeps.Types 36 | Types 37 | build-depends: 38 | , Cabal >= 3 39 | , aeson 40 | , aeson-pretty 41 | , base >= 4.11 && < 5 42 | , binary 43 | , binary-instances 44 | , bytestring 45 | , conduit 46 | , conduit-extra 47 | , containers 48 | , directory 49 | , filepath 50 | , hashable 51 | , http-client-tls 52 | , http-conduit 53 | , mtl 54 | , optparse-applicative 55 | , resourcet 56 | , scientific 57 | , split 58 | , streaming 59 | , streaming-bytestring 60 | , string-conversions 61 | , tar 62 | , temporary 63 | , text 64 | , transformers 65 | , typed-process 66 | , unordered-containers 67 | , yaml 68 | hs-source-dirs: 69 | src 70 | default-language: 71 | Haskell2010 72 | ghc-options: 73 | -Wall 74 | -O2 75 | 76 | executable pump 77 | main-is: 78 | Main.hs 79 | build-depends: 80 | , base 81 | , pump 82 | hs-source-dirs: 83 | app 84 | default-language: 85 | Haskell2010 86 | ghc-options: 87 | -threaded 88 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | with (import ./default.nix {}); 2 | 3 | hsPkgs.shellFor { 4 | packages = _: [ 5 | pump 6 | ]; 7 | 8 | withHoogle = false; 9 | 10 | buildInputs = with pkgs; [ 11 | cabal-install 12 | cabal2nix 13 | hsPkgs.bench 14 | hsPkgs.ghcid 15 | hsPkgs.json-autotype 16 | coreutils 17 | ]; 18 | } 19 | -------------------------------------------------------------------------------- /src/Commands.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | 3 | module Commands 4 | ( Command(..) 5 | , parseCommand 6 | ) where 7 | 8 | import Control.Applicative ((<|>), many) 9 | import Distribution.Package (PackageName) 10 | import qualified Options.Applicative as O 11 | 12 | import Types 13 | 14 | data Command 15 | = DownloadPackageIndex FilePath 16 | -- ^ (targetFile) 17 | -- 18 | -- download the package index and serialise it to 19 | -- @targetFile@ as binary 20 | | GenerateBuildMatrix FilePath PackageName (Maybe [PatchFile]) [PackageName] FilePath (Maybe FilePath) (Maybe Int) 21 | -- ^ (packageIndex, package, patches, excludedPackages, output, overrides, n) 22 | -- 23 | -- construct a build matrix of the reverse dependencies 24 | -- of @package@ (excluding @excludedPackages@), from 25 | -- @packageIndex@, applying @patches@ to the source of 26 | -- @package@, if any. @overrides@ will be applied to 27 | -- the reverse dependencies. 28 | -- 29 | -- If @n@ is given, the build matrix will only consider 30 | -- the top n immediate reverse dependencies of 31 | -- @package@, sorted by number of reverse dependencies. 32 | -- 33 | -- serialise the build matrix to @output@. 34 | | RealiseBuildMatrix Bool FilePath FilePath (Maybe FilePath) 35 | -- ^ (dontCheck, matrixJson, output, overrides) 36 | -- 37 | -- run the build matrix described by @matrixJson@, 38 | -- and dump the build report to @output@. 39 | -- 40 | -- @overrides@ are considered special when fetching; 41 | -- if any overrides fail to be fetched, then `realise` 42 | -- will terminate. 43 | -- 44 | -- @dontCheck@ determines whether or not to run tests. 45 | -- by default, it is 'False'. 46 | | Top FilePath PackageName Int 47 | -- ^ (packageIndex, package, n) 48 | -- 49 | -- Return a list of the top N most depended on 50 | -- immediate reverse dependencies of the package. 51 | 52 | cmdParser :: O.Parser Command 53 | cmdParser = O.subparser 54 | $ mconcat 55 | $ [ O.command "download" (O.info (O.helper <*> download) downloadInfo) 56 | , O.command "matrix" (O.info (O.helper <*> matrix) matrixInfo) 57 | , O.command "realise" (O.info (O.helper <*> realise) realiseInfo) 58 | , O.command "realize" (O.info (O.helper <*> realise) realiseInfo) 59 | , O.command "top" (O.info (O.helper <*> top) topInfo) 60 | ] 61 | where 62 | downloadInfo = O.fullDesc 63 | matrixInfo = O.fullDesc 64 | realiseInfo = O.fullDesc 65 | topInfo = O.fullDesc 66 | 67 | download = DownloadPackageIndex 68 | <$> ( O.strOption 69 | $ mconcat 70 | $ [ O.long "target" 71 | , O.short 'o' 72 | , O.help "where to dump binary package index" 73 | , O.metavar "FILEPATH" 74 | ] 75 | ) 76 | 77 | matrix = GenerateBuildMatrix 78 | <$> ( O.strOption 79 | $ mconcat 80 | $ [ O.long "index" 81 | , O.short 'i' 82 | , O.help "location of package index" 83 | , O.metavar "FILEPATH" 84 | ] 85 | ) 86 | <*> ( O.strOption 87 | $ mconcat 88 | $ [ O.long "pkg" 89 | , O.short 'p' 90 | , O.help "name of package" 91 | , O.metavar "PACKAGE NAME" 92 | ] 93 | ) 94 | <*> patchiz 95 | <*> ( many 96 | ( O.strOption 97 | $ mconcat 98 | $ [ O.long "exclude" 99 | , O.short 'e' 100 | , O.help "exclude the package from the output" 101 | , O.metavar "PACKAGE NAME" 102 | ] 103 | ) 104 | ) 105 | <*> ( O.strOption 106 | $ mconcat 107 | $ [ O.long "target" 108 | , O.short 'o' 109 | , O.help "where to dump serialised build matrix" 110 | , O.metavar "FILEPATH" 111 | ] 112 | ) 113 | <*> overrides 114 | <*> (pure Nothing <|> (fmap Just $ O.option O.auto 115 | $ mconcat 116 | $ [ O.short 'n' 117 | , O.help "top N most depended on immediate reverse dependencies" 118 | , O.metavar "INT" 119 | ] 120 | )) 121 | 122 | realise = RealiseBuildMatrix 123 | <$> ( O.switch 124 | $ mconcat 125 | $ [ O.long "dontCheck" 126 | , O.help "whether or not to run tests" 127 | ] 128 | ) 129 | <*> ( O.strOption 130 | $ mconcat 131 | $ [ O.long "matrix" 132 | , O.short 'm' 133 | , O.help "location of build matrix description" 134 | , O.metavar "JSON FILEPATH" 135 | ] 136 | ) 137 | <*> ( O.strOption 138 | $ mconcat 139 | $ [ O.long "target" 140 | , O.short 'o' 141 | , O.help "where to dump serialised build report" 142 | , O.metavar "FILEPATH" 143 | ] 144 | ) 145 | <*> overrides 146 | 147 | top = Top 148 | <$> ( O.strOption 149 | $ mconcat 150 | $ [ O.long "index" 151 | , O.short 'i' 152 | , O.help "location of package index" 153 | , O.metavar "FILEPATH" 154 | ] 155 | ) 156 | <*> ( O.strOption 157 | $ mconcat 158 | $ [ O.long "pkg" 159 | , O.short 'p' 160 | , O.help "name of package" 161 | , O.metavar "PACKAGE NAME" 162 | ] 163 | ) 164 | <*> ( O.option O.auto 165 | $ mconcat 166 | $ [ O.short 'n' 167 | , O.help "Get top N most depended on immediate reverse dependencies" 168 | , O.metavar "INT" 169 | ] 170 | ) 171 | 172 | overrides = pure Nothing 173 | <|> ( fmap Just 174 | $ O.strOption 175 | $ mconcat 176 | $ [ O.long "overrides" 177 | , O.help "source overrides" 178 | , O.metavar "FILEPATH" 179 | ] 180 | ) 181 | 182 | patchiz = id 183 | $ fmap (\case { [] -> Nothing; xs -> Just xs; }) 184 | $ many 185 | $ O.strOption 186 | $ mconcat 187 | $ [ O.long "patch" 188 | , O.help "patch file to apply to package source" 189 | , O.metavar "PATCHFILE" 190 | ] 191 | 192 | parseCommand :: IO Command 193 | parseCommand = O.execParser 194 | $ O.info (O.helper <*> cmdParser) 195 | $ mconcat 196 | $ [ O.fullDesc 197 | ] 198 | 199 | -------------------------------------------------------------------------------- /src/Fetch.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language NumericUnderscores #-} 3 | {-# language OverloadedStrings #-} 4 | {-# language RecordWildCards #-} 5 | 6 | module Fetch 7 | ( fetchIndex 8 | , fetchGz 9 | , fetchSource 10 | ) 11 | where 12 | 13 | import Conduit 14 | import Control.Monad 15 | import Control.Monad.Except (throwError, liftEither, runExceptT) 16 | import Data.Conduit.Zlib (ungzip) 17 | import Data.Maybe 18 | import Distribution.Package (PackageIdentifier(..), unPackageName) 19 | import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) 20 | import Distribution.Types.GenericPackageDescription (GenericPackageDescription(..)) 21 | import Distribution.Version (Version, versionNumbers) 22 | import Network.HTTP.Client.TLS (getGlobalManager) 23 | import Network.HTTP.Conduit 24 | import PackDeps (loadNewestFrom) 25 | import PackDeps.Types (Newest) 26 | import System.Directory (withCurrentDirectory, listDirectory) 27 | import System.Exit (ExitCode(..)) 28 | import System.FilePath (takeExtension, ()) 29 | import System.Process.Typed 30 | import qualified Codec.Archive.Tar as Tar 31 | import qualified Data.ByteString as B 32 | import qualified Data.ByteString.Lazy as BL 33 | import qualified Data.List as List 34 | import qualified Distribution.Types.PackageDescription as PackageDescription 35 | 36 | import FileSystem 37 | import Types 38 | 39 | fetchIndex :: IO Newest 40 | fetchIndex = do 41 | let url = "http://hackage.haskell.org/01-index.tar.gz" 42 | fetchGz url "newest-index.tar" Nothing $ \index -> do 43 | newest <- loadNewestFrom index 44 | pure newest 45 | 46 | fetchGz :: String 47 | -> FilePath 48 | -> Maybe FilePath 49 | -> (FilePath -> IO a) 50 | -> IO a 51 | fetchGz url outFile mtmpDir fromFile = do 52 | req <- do 53 | req0 <- parseUrlThrow url 54 | pure (req0 { responseTimeout = responseTimeoutMicro 3_000_000 }) 55 | m <- getGlobalManager 56 | 57 | let sink = case mtmpDir of 58 | Nothing -> sinkSystemTempFile 59 | Just tmpDir -> sinkTempFile tmpDir 60 | 61 | runResourceT $ do 62 | res <- http req m 63 | streamedFile <- runConduit $ 64 | responseBody res 65 | .| ungzip 66 | .| sink outFile 67 | liftIO $ fromFile streamedFile 68 | 69 | fetchSource :: () 70 | => PackageSource 71 | -> IO ( Either 72 | (ExitCode, BL.ByteString, BL.ByteString) 73 | (FilePath, Version) 74 | ) 75 | fetchSource = \case 76 | HackageGet{..} -> do 77 | let pkgNameStr = unPackageName package 78 | let fullPkgName = pkgNameStr ++ "-" ++ showVersion version 79 | let url = "https://hackage.haskell.org/package/" 80 | ++ fullPkgName 81 | ++ "/" 82 | ++ fullPkgName 83 | ++ ".tar.gz" 84 | let srcDir = fullPkgName 85 | fetchGz url (pkgNameStr ++ ".tar") (Just ".") $ \tarFile -> do 86 | Tar.extract "." tarFile 87 | pure $ Right (srcDir, version) 88 | FetchFromGitHub{..} -> runExceptT $ do 89 | let srcDir0 = unPackageName package 90 | let gitUrl = "https://github.com/" 91 | ++ owner 92 | ++ "/" ++ repo 93 | o0@(e0, _, _) <- readProcess $ proc "git" ["clone", gitUrl, srcDir0] 94 | when (e0 /= ExitSuccess) $ throwError o0 95 | o1@(e1, _, _) <- liftIO $ withCurrentDirectory srcDir0 $ do 96 | readProcess $ proc "git" $ ["checkout"] ++ 97 | maybeToList rev 98 | when (e1 /= ExitSuccess) $ throwError o1 99 | let srcDir1 = maybe srcDir0 (srcDir0 ) subPath 100 | version <- (liftEither =<<) $ liftIO $ withCurrentDirectory srcDir1 $ do 101 | stuff <- listDirectory "." 102 | case List.find (\file -> takeExtension file == ".cabal") stuff of 103 | Nothing -> pure $ Left (ExitFailure 1, "", "No cabal file found in package") 104 | Just cabalFile -> do 105 | mgpd <- do 106 | b <- B.readFile cabalFile 107 | pure $ parseGenericPackageDescriptionMaybe b 108 | 109 | pure $ case mgpd of 110 | Nothing -> Left (ExitFailure 1, "", "Failed to parse cabal file") 111 | Just gpd -> Right $ pkgVersion $ PackageDescription.package $ packageDescription gpd 112 | 113 | -- once we have the version, we need to copy everything over 114 | -- to the new directory 115 | let srcDir = srcDir1 ++ "-" ++ showVersion version 116 | -- could be pretty slow. will have to find out. 117 | liftIO $ do 118 | readFsFilter (/= ".git") srcDir1 >>= \case 119 | File {} -> fail "shouldn't happen" 120 | Dir _ fs -> writeFs $ Dir srcDir fs 121 | pure (srcDir, version) 122 | 123 | showVersion :: Version -> String 124 | showVersion = List.intercalate "." . map show . versionNumbers 125 | -------------------------------------------------------------------------------- /src/FileSystem.hs: -------------------------------------------------------------------------------- 1 | {-# language DerivingStrategies #-} 2 | {-# language LambdaCase #-} 3 | 4 | module FileSystem 5 | ( FileSystem(..) 6 | , readFs 7 | , readFsFilter 8 | , writeFs 9 | ) where 10 | 11 | import Control.Monad 12 | import Data.Foldable (for_) 13 | import Data.ByteString (ByteString) 14 | import System.Directory (createDirectoryIfMissing, withCurrentDirectory, listDirectory, doesFileExist) 15 | 16 | import qualified Data.ByteString as B 17 | 18 | data FileSystem 19 | = File FilePath ByteString 20 | | Dir FilePath [FileSystem] 21 | deriving stock (Eq, Show) 22 | 23 | writeFs :: FileSystem -> IO () 24 | writeFs = \case 25 | File name content -> do 26 | B.writeFile name content 27 | Dir name children -> do 28 | createDirectoryIfMissing False name 29 | withCurrentDirectory name $ for_ children writeFs 30 | 31 | readFs :: FilePath -> IO FileSystem 32 | readFs = readFsFilter (const True) 33 | 34 | readFsFilter :: (FilePath -> Bool) -> FilePath -> IO FileSystem 35 | readFsFilter p sourceDir = withCurrentDirectory sourceDir $ do 36 | lsOutput <- filter p <$> listDirectory "." 37 | fs <- fmap concat $ forM lsOutput $ \name -> do 38 | isFile <- doesFileExist name 39 | if isFile 40 | then do 41 | contents <- B.readFile name 42 | pure [File name contents] 43 | else do 44 | fs <- readFs name 45 | pure [fs] 46 | pure (Dir sourceDir fs) 47 | 48 | -------------------------------------------------------------------------------- /src/PackDeps.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language OverloadedStrings #-} 3 | {-# language TupleSections #-} 4 | {-# language ViewPatterns #-} 5 | 6 | module PackDeps 7 | ( Newest(..) 8 | , Reverses 9 | , PackInfo(..) 10 | 11 | , loadNewestFrom 12 | , getReverses 13 | ) where 14 | 15 | import Control.Exception (throw) 16 | import Data.Foldable (foldl') 17 | import Data.HashMap.Strict (HashMap) 18 | import Data.Hashable (Hashable) 19 | import Data.List.Split (splitOn) 20 | import Data.Maybe (mapMaybe) 21 | import Distribution.Package (PackageName, Dependency(..), mkPackageName, unPackageName) 22 | import Distribution.PackageDescription 23 | import Distribution.PackageDescription.Parsec (runParseResult, parseGenericPackageDescription) 24 | import Distribution.Text (simpleParse) 25 | import Distribution.Types.CondTree (CondBranch (..)) 26 | import Distribution.Version (Version, VersionRange, withinRange) 27 | import PackDeps.Types 28 | import qualified Codec.Archive.Tar as Tar 29 | import qualified Codec.Archive.Tar.Entry as Tar 30 | import qualified Data.ByteString.Lazy as L 31 | import qualified Data.HashMap.Strict as HMap 32 | import qualified Data.Map as Map 33 | import qualified Data.Text as T 34 | 35 | loadNewestFrom :: FilePath -> IO Newest 36 | loadNewestFrom = fmap parseNewest . L.readFile 37 | 38 | parseNewest :: L.ByteString -> Newest 39 | parseNewest = id 40 | . fst 41 | . foldl' addPackage (Newest HMap.empty, 0) 42 | . entriesToList 43 | . Tar.read 44 | 45 | entriesToList :: Tar.Entries Tar.FormatError -> [Tar.Entry] 46 | entriesToList = \case 47 | Tar.Done -> [] 48 | Tar.Fail s -> throw s 49 | Tar.Next e es -> e : entriesToList es 50 | 51 | addPackage :: (Newest, Int) -> Tar.Entry -> (Newest, Int) 52 | addPackage (Newest m, count) entry = (Newest m', count') 53 | where 54 | (m', count') = case splitOn "/" (Tar.fromTarPathToPosixPath (Tar.entryTarPath entry)) of 55 | -- we don't care about acme packages 56 | (packageName : _) | "acme" `T.isPrefixOf` T.pack packageName -> (m, count) 57 | [packageStr, versionStr, nameStr] | ".cabal" `T.isSuffixOf` T.pack nameStr -> 58 | let packageName = mkPackageName packageStr 59 | in case simpleParse versionStr of 60 | Nothing -> (m, count) 61 | Just newv -> case HMap.lookup packageName m of 62 | Nothing -> go packageName newv 63 | Just PackInfo { version = oldv } -> 64 | if newv >= oldv 65 | then go packageName newv 66 | else (m, count) 67 | _ -> (m, count) 68 | go :: PackageName 69 | -> Version 70 | -> (HashMap PackageName PackInfo, Int) 71 | go p v = case Tar.entryContent entry of 72 | Tar.NormalFile bs _ -> 73 | let packInfo = PackInfo 74 | { version = v 75 | , desc = getDeps bs 76 | , epoch = Tar.entryTime entry 77 | } 78 | in (HMap.insert p packInfo m, count + 1) 79 | _ -> (m, count) 80 | 81 | getReverses :: Newest -> Reverses 82 | getReverses (Newest newest) = HMap.fromList withVersion 83 | where 84 | toTuples (_, PackInfo { desc = Nothing }) = HMap.empty 85 | toTuples (rel, PackInfo { desc = Just deps }) 86 | -- TODO: ignore deprecated packages (requires looking at synposis) 87 | -- | isDeprecated deps = HMap.empty 88 | | otherwise = combine $ map (toTuple rel) $ HMap.toList deps 89 | combine = unionsWith HMap.union 90 | 91 | toTuple rel (dep, PUVersionRange _ range) 92 | | rel == dep = HMap.empty 93 | | otherwise = HMap.singleton dep (HMap.singleton rel range) 94 | 95 | hoisted :: HashMap PackageName (HashMap PackageName VersionRange) 96 | hoisted = combine $ map toTuples $ HMap.toList newest 97 | 98 | withVersion = mapMaybe addVersion $ HMap.toList hoisted 99 | 100 | addVersion (dep, rels) = case HMap.lookup dep newest of 101 | Nothing -> Nothing 102 | Just (PackInfo { version = v }) -> Just (dep, (v, rels)) 103 | 104 | unionsWith :: (Foldable f, Hashable k, Eq k) 105 | => (v -> v -> v) 106 | -> f (HashMap k v) 107 | -> HashMap k v 108 | unionsWith f = foldl' (HMap.unionWith f) HMap.empty 109 | 110 | getDeps :: L.ByteString -> Maybe (HashMap PackageName PUVersionRange) 111 | getDeps lbs = do 112 | gpd <- id $ either (const Nothing) Just 113 | $ snd 114 | $ runParseResult 115 | $ parseGenericPackageDescription 116 | $ L.toStrict lbs 117 | let flagMaps = 118 | let loop = \case 119 | [] -> pure Map.empty 120 | (f : fs) -> do 121 | let name = flagName f 122 | let def = flagDefault f 123 | rest <- loop fs 124 | [Map.insert name def rest, Map.insert name (not def) rest] 125 | 126 | in take 10 . loop . genPackageFlags $ gpd 127 | 128 | allowsNewBase :: [Dependency] -> Bool 129 | allowsNewBase = all ok 130 | where 131 | Just newbase = simpleParse "4.10.0.0" 132 | 133 | ok :: Dependency -> Bool 134 | ok (Dependency (unPackageName -> "base") range _) 135 | = newbase `withinRange` range 136 | ok _ = True 137 | 138 | go' fm tree = id 139 | $ concat 140 | $ condTreeConstraints tree 141 | : map (go' fm) (mapMaybe (checkCond fm) (condTreeComponents tree)) 142 | 143 | checkCond fm (CondBranch cond tree melse) 144 | | checkCond' fm cond = Just tree 145 | | otherwise = melse 146 | 147 | 148 | checkCond' fm = \case 149 | Var (OS _) -> True 150 | Var (Arch _) -> True 151 | Var (Flag f) -> Map.findWithDefault False f fm 152 | Var (Impl _ _) -> True 153 | Lit b -> b 154 | CNot c -> not (checkCond' fm c) 155 | COr c1 c2 -> checkCond' fm c1 || checkCond' fm c2 156 | CAnd c1 c2 -> checkCond' fm c1 && checkCond' fm c2 157 | 158 | go :: PackageUsage 159 | -> CondTree ConfVar [Dependency] a 160 | -> [(Dependency, PackageUsage)] 161 | go pu tree = map (,pu) 162 | $ case filter allowsNewBase choices of 163 | [] -> case choices of 164 | [] -> [] 165 | (c : _) -> c 166 | (c : _) -> c 167 | where 168 | choices = map (flip go' tree) flagMaps 169 | 170 | pure $ foldr (HMap.unionWith (<>)) HMap.empty 171 | $ map (\(Dependency k v _, pu) -> HMap.singleton 172 | k 173 | (PUVersionRange pu v) 174 | ) 175 | $ mconcat 176 | $ [ maybe mempty (map (,Runtime) . setupDepends) 177 | $ setupBuildInfo $ packageDescription gpd 178 | , maybe mempty (go Runtime) (condLibrary gpd) 179 | , foldMap (go Runtime . snd) (condSubLibraries gpd) 180 | , foldMap (go Runtime . snd) (condForeignLibs gpd) 181 | , foldMap (go Runtime . snd) (condExecutables gpd) 182 | , foldMap (go TestBench . snd) (condTestSuites gpd) 183 | , foldMap (go TestBench . snd) (condBenchmarks gpd) 184 | ] 185 | 186 | {- 187 | checkDeps :: Newest 188 | -> (PackageName, Version, DescInfo PackageName Version) 189 | -> (PackageName, Version, CheckDepsRes) 190 | checkDeps newest (name, version, desc) = 191 | case mapMaybe (notNewest newest) $ HMap.toList $ diDeps desc of 192 | [] -> (name, version, AllNewest) 193 | x -> let y = HMap.fromList $ map fst x 194 | et = maximum $ map snd x 195 | in (name, version, WontAccept y $ epochToTime et) 196 | 197 | -- | Whether or not a package can accept all of the newest versions of its 198 | -- dependencies. If not, it returns a list of packages which are not accepted, 199 | -- and a timestamp of the most recently updated package. 200 | data CheckDepsRes = AllNewest 201 | | WontAccept (HMap.HashMap PackageName Outdated) UTCTime 202 | deriving Show 203 | 204 | data Outdated = Outdated Version Reason 205 | 206 | instance Show Outdated where 207 | show (Outdated _ Deprecated) = "deprecated" 208 | show (Outdated version NewerAvailable) = show version 209 | show (Outdated version NewerAndDeprecated) = show version ++ " (deprecated)" 210 | 211 | data Reason = NewerAvailable | Deprecated | NewerAndDeprecated 212 | deriving Show 213 | 214 | epochToTime :: Tar.EpochTime -> UTCTime 215 | epochToTime e = addUTCTime (fromIntegral e) $ UTCTime (read "1970-01-01") 0 216 | 217 | notNewest :: Newest 218 | -> (PackageName, PUVersionRange (VersionRange Version)) 219 | -> Maybe ((PackageName, Outdated), Tar.EpochTime) 220 | notNewest (Newest newest) (s, PUVersionRange _ range) = 221 | case HMap.lookup s newest of 222 | --Nothing -> Just ((s, " no version found"), 0) 223 | Nothing -> Nothing 224 | Just PackInfo { piVersion = version, piEpoch = e, piDesc = d } -> 225 | let mreason = 226 | case (maybe' False isDeprecated d, not $ withinRange version range) of 227 | (False, False) -> Nothing 228 | (True, False) -> Just Deprecated 229 | (False, True) -> Just NewerAvailable 230 | (True, True) -> Just NewerAndDeprecated 231 | in flip fmap mreason $ \reason -> ((s, Outdated version reason), e) 232 | 233 | -- | Loads up the newest version of a package from the 'Newest' list, if 234 | -- available. 235 | getPackage :: PackageName -> Newest -> Maybe (PackageName, Version, DescInfo PackageName Version) 236 | getPackage s (Newest n) = do 237 | pi <- HMap.lookup s n 238 | di <- m'ToM $ piDesc pi 239 | return (s, piVersion pi, di) 240 | -} 241 | 242 | {- 243 | -- | Load a single package from a cabal file. 244 | loadPackage :: FilePath -> IO (Maybe' (DescInfo PackageName Version)) 245 | loadPackage = fmap (fmap fst . parsePackage) . L.readFile 246 | 247 | isDeprecated :: DescInfo name version -> Bool 248 | isDeprecated desc = "(deprecated)" `isInfixOf` diSynopsis desc 249 | 250 | -- | Find all of the packages matching a given search string. 251 | filterPackages :: Text -> Newest -> [(PackageName, Version, DescInfo PackageName Version)] 252 | filterPackages needle = 253 | mapMaybe go . HMap.toList . unNewest 254 | where 255 | go (name, PackInfo { piVersion = v, piDesc = Just' desc }) = 256 | if matches (diHaystack desc) && 257 | not (isDeprecated desc) 258 | then Just (name, v, desc) 259 | else Nothing 260 | go _ = Nothing 261 | 262 | matches haystack 263 | | Just needle' <- TS.stripPrefix "exact:" needle = all (`elem` TS.words haystack) $ TS.words $ toCaseFold needle' 264 | | otherwise = 265 | let (needle', excludes) = splitExcludes $ toCaseFold needle 266 | in (needle' `isInfixOf` haystack) && all (\t -> not $ t `isInfixOf` haystack) excludes 267 | 268 | splitExcludes = second (filter (not . TS.null) . TS.split (== '!')) 269 | . TS.break (== '!') 270 | 271 | -- | Find all packages depended upon by the given list of packages. 272 | deepDeps :: Newest 273 | -> [(PackageName, Version, DescInfo PackageName Version)] 274 | -> [(PackageName, Version, DescInfo PackageName Version)] 275 | deepDeps (Newest newest) dis0 = 276 | go Set.empty dis0 277 | where 278 | go _ [] = [] 279 | go viewed ((name, v, di):dis) 280 | | name `Set.member` viewed = go viewed dis 281 | | otherwise = (name, v, di) : go viewed' (newDis ++ dis) 282 | where 283 | viewed' = Set.insert name viewed 284 | newDis = mapMaybe getDI $ HMap.keys $ diDeps di 285 | getDI name' = do 286 | pi <- HMap.lookup name' newest 287 | di' <- m'ToM $ piDesc pi 288 | return (name', piVersion pi, di') 289 | 290 | data LMS = LMS 291 | { _lmsProcessed :: Set.Set PackageName 292 | , _lmsToProcess :: [PackageName] 293 | , _lmsResult :: LicenseMap 294 | } 295 | makeLenses ''LMS 296 | 297 | getLicenseMap :: Bool -- ^ include test/benchmarks 298 | -> Newest -> LicenseMap 299 | getLicenseMap includeTests (Newest newest) = 300 | evalState go (LMS Set.empty (HMap.keys newest) Map.empty) 301 | where 302 | go = do 303 | lms <- get 304 | case lms ^. lmsToProcess of 305 | [] -> return $ lms ^. lmsResult 306 | p:rest -> do 307 | lmsToProcess %= const rest 308 | _ <- getLicenses p 309 | go 310 | 311 | getLicenses :: PackageName -> State LMS Licenses 312 | getLicenses p = do 313 | lms1 <- get 314 | if p `Set.member` (lms1 ^. lmsProcessed) 315 | then return $ fromMaybe mempty $ Map.lookup p $ lms1 ^. lmsResult 316 | else do 317 | lmsProcessed %= Set.insert p 318 | case HMap.lookup p newest of 319 | Nothing -> return mempty 320 | Just pi -> do 321 | let ls1 = Licenses $ Map.singleton (piLicense pi) $ Set.singleton p 322 | deps = 323 | case piDesc pi of 324 | Nothing' -> [] 325 | Just' di -> map fst $ filter isIncluded $ HMap.toList $ diDeps di 326 | lss <- mapM getLicenses deps 327 | let ls = mconcat $ ls1 : lss 328 | lmsResult %= Map.insert p ls 329 | return ls 330 | 331 | isIncluded (_, PUVersionRange Runtime _) = True 332 | isIncluded (_, PUVersionRange TestBench _) = includeTests 333 | -} 334 | -------------------------------------------------------------------------------- /src/PackDeps/Types.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveAnyClass #-} 2 | {-# language DeriveGeneric #-} 3 | {-# language DerivingStrategies #-} 4 | {-# language GeneralizedNewtypeDeriving #-} 5 | 6 | -- for hashable instances 7 | {-# options_ghc -fno-warn-orphans #-} 8 | 9 | module PackDeps.Types 10 | ( Newest(..) 11 | , Reverses 12 | , PackInfo(..) 13 | , PUVersionRange(..) 14 | , PackageUsage(..) 15 | ) where 16 | 17 | import Data.Aeson (ToJSON(..), FromJSON(..), Value(..)) 18 | import Data.Binary (Binary) 19 | import Data.Binary.Instances.UnorderedContainers () 20 | import Data.HashMap.Strict (HashMap) 21 | import Data.Hashable (Hashable(..)) 22 | import Data.Int (Int64) 23 | import Distribution.Text (simpleParse) 24 | import Distribution.Types.PackageName (PackageName, unPackageName, mkPackageName) 25 | import Distribution.Types.VersionRange.Internal (VersionRange(..)) 26 | import Distribution.Utils.ShortText (ShortText, fromShortText) 27 | import Distribution.Version (Version, simplifyVersionRange, versionNumbers) 28 | import GHC.Generics (Generic) 29 | 30 | import qualified Data.Aeson as Aeson 31 | import qualified Data.List as List 32 | import qualified Data.Text as T 33 | 34 | instance Hashable PackageName where 35 | hashWithSalt i = hashWithSalt i . unPackageName 36 | instance Hashable ShortText where 37 | hashWithSalt i = hashWithSalt i . fromShortText 38 | 39 | instance ToJSON Version where 40 | toJSON = id 41 | . String 42 | . T.pack 43 | . List.intercalate "." 44 | . map show 45 | . versionNumbers 46 | 47 | instance FromJSON Version where 48 | parseJSON = Aeson.withText "Version" $ \t -> case simpleParse (T.unpack t) of 49 | Nothing -> fail "Version" 50 | Just v -> pure v 51 | 52 | instance ToJSON PackageName where 53 | toJSON = toJSON . unPackageName 54 | 55 | instance FromJSON PackageName where 56 | parseJSON = fmap mkPackageName . parseJSON 57 | 58 | newtype Newest = Newest { getNewest :: HashMap PackageName PackInfo } 59 | deriving stock (Show) 60 | deriving newtype (Eq, Binary) 61 | 62 | type Reverses = HashMap PackageName (Version, HashMap PackageName VersionRange) 63 | 64 | data PackInfo = PackInfo 65 | { version :: Version 66 | , desc :: Maybe (HashMap PackageName PUVersionRange) 67 | , epoch :: Int64 68 | } 69 | deriving stock (Eq, Show, Generic) 70 | deriving anyclass (Binary) 71 | 72 | data PUVersionRange = PUVersionRange PackageUsage VersionRange 73 | deriving stock (Eq, Show, Generic) 74 | deriving anyclass (Binary) 75 | 76 | instance Semigroup PUVersionRange where 77 | PUVersionRange a x <> PUVersionRange b y 78 | = PUVersionRange 79 | (a <> b) 80 | (simplifyVersionRange $ IntersectVersionRanges x y) 81 | 82 | data PackageUsage = Runtime | TestBench 83 | deriving stock (Eq, Show, Generic) 84 | deriving anyclass (Binary) 85 | 86 | instance Semigroup PackageUsage where 87 | Runtime <> _ = Runtime 88 | TestBench <> x = x 89 | 90 | instance Monoid PackageUsage where 91 | mempty = TestBench 92 | -------------------------------------------------------------------------------- /src/Pump.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language NumericUnderscores #-} 3 | {-# language OverloadedStrings #-} 4 | {-# language RecordWildCards #-} 5 | {-# language ScopedTypeVariables #-} 6 | {-# language TypeApplications #-} 7 | {-# language ViewPatterns #-} 8 | 9 | module Pump (main) where 10 | 11 | import Control.Monad 12 | import Control.Monad.IO.Class (liftIO) 13 | import Control.Monad.Trans.Class (lift) 14 | import Control.Monad.Trans.Resource (runResourceT) 15 | import Data.Aeson (ToJSON(..)) 16 | import Data.Binary (encodeFile, decodeFile) 17 | import Data.Maybe 18 | import Data.Ord (Down(..)) 19 | import Data.String.Conversions (cs) 20 | import Distribution.Package (PackageName, unPackageName) 21 | import Distribution.Version (Version, nullVersion, withinRange) 22 | import PackDeps (Newest(..), PackInfo(..), Reverses, getReverses) 23 | import Streaming (Stream, Of(..)) 24 | import System.Directory (withCurrentDirectory, getCurrentDirectory, makeAbsolute, removeDirectoryRecursive) 25 | import System.Exit (ExitCode(..)) 26 | import System.FilePath (isAbsolute, ()) 27 | import System.IO.Temp (getCanonicalTemporaryDirectory, withTempDirectory) 28 | import System.Process.Typed 29 | import qualified Data.Aeson as Aeson 30 | import qualified Data.ByteString as B 31 | import qualified Data.ByteString.Char8 as BC8 32 | import qualified Data.ByteString.Streaming as SB 33 | import qualified Data.ByteString.Streaming.Char8 as SBC8 34 | import qualified Data.HashMap.Strict as HMap 35 | import qualified Data.List as List 36 | import qualified Data.Yaml as Yaml 37 | import qualified Streaming as S 38 | import qualified Streaming.Prelude as S 39 | 40 | import Commands 41 | import Fetch 42 | import Types 43 | 44 | doCommand :: Command -> IO () 45 | doCommand = \case 46 | 47 | DownloadPackageIndex outFile -> do 48 | downloadPackageIndex outFile 49 | 50 | GenerateBuildMatrix packageIndex package patches excludedPackages outFile overridesPath n -> do 51 | overrides <- loadOverrides overridesPath 52 | newest <- decodeFile @Newest packageIndex 53 | let matrix = generateBuildMatrix newest package patches excludedPackages overrides n 54 | serialiseToFile outFile matrix 55 | 56 | RealiseBuildMatrix dontCheck matrixJson outFile overridesPath -> do 57 | BuildMatrix{..} <- loadBuildMatrix matrixJson 58 | overrides <- loadOverrides overridesPath 59 | build outFile dontCheck packageSrc dependencies overrides 60 | 61 | Top packageIndex package n -> do 62 | newest <- decodeFile @Newest packageIndex 63 | let reverses = getReverses newest 64 | let tops = topDependencies reverses package n 65 | forM_ tops (putStrLn . unPackageName) 66 | 67 | loadOverrides :: Maybe FilePath -> IO [PackageSource] 68 | loadOverrides = \case 69 | Nothing -> do 70 | pure [] 71 | Just path -> do 72 | Yaml.decodeFileThrow @_ @[PackageSource] path 73 | 74 | loadBuildMatrix :: FilePath -> IO BuildMatrix 75 | loadBuildMatrix path = do 76 | Yaml.decodeFileThrow @_ @BuildMatrix path 77 | 78 | downloadPackageIndex :: () 79 | => FilePath 80 | -> IO () 81 | downloadPackageIndex outFile = do 82 | newest <- fetchIndex 83 | encodeFile outFile newest 84 | 85 | getPackagesForMatrix :: () 86 | => Reverses 87 | -> PackageName 88 | -> [PackageName] 89 | -> Maybe Int 90 | -> (Version, [PackageName]) 91 | getPackagesForMatrix reverses package excludedPackages = \case 92 | Nothing -> 93 | case HMap.lookup package reverses of 94 | Nothing -> (nullVersion, []) 95 | Just (packageVersion, revDeps0) -> 96 | let keepPackage (pkg, rng) = True 97 | && pkg `notElem` excludedPackages 98 | && withinRange packageVersion rng 99 | revDeps1 = id 100 | $ map fst 101 | $ filter keepPackage 102 | $ HMap.toList revDeps0 103 | in (packageVersion, revDeps1) 104 | Just n -> 105 | let version = maybe nullVersion fst $ HMap.lookup package reverses 106 | revDeps = id 107 | $ filter (`notElem` excludedPackages) 108 | $ topDependencies reverses package n 109 | in (version, revDeps) 110 | 111 | -- TODO: filter deprecated packages 112 | generateBuildMatrix :: () 113 | => Newest 114 | -> PackageName 115 | -> Maybe [PatchFile] 116 | -> [PackageName] 117 | -> [PackageSource] 118 | -> Maybe Int 119 | -> BuildMatrix 120 | generateBuildMatrix newest package patches excludedPackages overrides n = 121 | let reverses = getReverses newest 122 | (version, revDeps) = getPackagesForMatrix reverses package excludedPackages n 123 | 124 | in BuildMatrix 125 | { packageSrc = case findPkg package overrides of 126 | Just src -> src 127 | Nothing -> HackageGet package version 128 | , dependencies = flip map revDeps $ \name -> 129 | case findPkg name overrides of 130 | Just src -> src 131 | -- we always default to hackage 132 | Nothing -> 133 | let PackInfo v _ _ = id 134 | $ fromMaybe (error ("package not found: " ++ unPackageName name)) 135 | $ HMap.lookup name (getNewest newest) 136 | in HackageGet name v 137 | , .. 138 | } 139 | 140 | topDependencies :: () 141 | => Reverses 142 | -> PackageName 143 | -> Int 144 | -> [PackageName] 145 | topDependencies reverses package n = id 146 | $ List.take n 147 | $ map fst 148 | $ List.sortOn (Down . snd) 149 | $ mapMaybe 150 | (\p -> do 151 | h <- HMap.lookup p reverses 152 | pure (p, HMap.size (snd h)) 153 | ) 154 | $ directDependencies package reverses 155 | 156 | directDependencies :: PackageName -> Reverses -> [PackageName] 157 | directDependencies package reverses = id 158 | $ HMap.keys 159 | $ maybe (error (show package ++ ": package doesn't exist")) snd 160 | $ HMap.lookup package 161 | $ reverses 162 | 163 | findPkg :: PackageName -> [PackageSource] -> Maybe PackageSource 164 | findPkg name = List.find $ \case 165 | HackageGet{..} -> package == name 166 | FetchFromGitHub{..} -> package == name 167 | 168 | main :: IO () 169 | main = doCommand =<< parseCommand 170 | 171 | build :: () 172 | => FilePath 173 | -> Bool 174 | -> PackageSource 175 | -> [PackageSource] 176 | -> [PackageSource] 177 | -> IO () 178 | build outFile' _dontCheck pkg deps overrides = do 179 | outFile <- do 180 | if isAbsolute outFile' 181 | then pure outFile' 182 | else do 183 | cwd <- getCurrentDirectory 184 | makeAbsolute (cwd outFile') 185 | tmpDir <- getCanonicalTemporaryDirectory 186 | let envSuffix = unPackageName (package pkg) 187 | let template = "pump-the-brakes-" ++ envSuffix 188 | let allPkgs = pkg : deps 189 | withTempDirectory tmpDir template $ \dir -> withCurrentDirectory dir $ do 190 | srcDir <- either (error . show) fst <$> fetchSource pkg 191 | 192 | runResourceT 193 | $ SB.writeFile outFile 194 | $ flip SBC8.snoc ']' 195 | $ SBC8.cons '[' 196 | $ SB.fromChunks 197 | $ streamSep (BC8.singleton ',') 198 | $ S.map (cs . Aeson.encode) 199 | $ mapStreamM 200 | (\src -> do 201 | epath <- liftIO $ fetchSource src 202 | case epath of 203 | Left (exitCode, (cs -> stdout), (cs -> stderr)) -> do 204 | let report = BuildReport 205 | { pkg = sourcePackage src 206 | , version = sourceVersion src 207 | , phase = Fetching 208 | , .. 209 | } 210 | S.yield report 211 | let pkgName = sourcePackage src 212 | when (isJust (findPkg pkgName overrides)) $ do 213 | let err = unlines 214 | [ "Failed to fetch " ++ unPackageName pkgName ++ "." 215 | , " exit code: " ++ show (exitCodeToInt exitCode) 216 | , " stderr was: " ++ cs stderr 217 | ] 218 | fail err 219 | Right (p, v) -> do 220 | liftIO $ createCabalProject p srcDir 221 | 222 | buildReport <- liftIO $ do 223 | putStrLn $ "Building " ++ p ++ "..." 224 | runCabal Building (package src) v 225 | S.yield buildReport 226 | 227 | testReport <- liftIO $ do 228 | putStrLn $ "Testing " ++ p ++ "..." 229 | runCabal Testing (package src) v 230 | S.yield testReport 231 | 232 | when (p /= srcDir) $ liftIO $ do 233 | removeDirectoryRecursive p 234 | ) 235 | $ S.each 236 | $ allPkgs 237 | 238 | runCabal :: Phase -> PackageName -> Version -> IO BuildReport 239 | runCabal phase p v = 240 | case phase of 241 | Fetching -> do 242 | fail $ "Cabal should not be running during FetchPhase." 243 | Building -> do 244 | (e, out, err) <- readProcess $ proc "cabal" ["v2-build", "all"] 245 | pure $ BuildReport p (Just v) Building e (cs out) (cs err) 246 | Testing -> do 247 | (e, out, err) <- readProcess $ proc "cabal" ["v2-test", "all"] 248 | pure $ BuildReport p (Just v) Testing e (cs out) (cs err) 249 | 250 | mapStreamM :: Monad m 251 | => (a -> Stream (Of b) m x) 252 | -> Stream (Of a) m r 253 | -> Stream (Of b) m r 254 | mapStreamM f = id 255 | . S.concats 256 | . S.mapsM 257 | (\(a :> s) -> pure (f a *> pure s) 258 | ) 259 | 260 | createCabalProject :: FilePath -> FilePath -> IO () 261 | createCabalProject depFile srcDir 262 | | depFile == srcDir = do 263 | writeFile "cabal.project" 264 | $ unlines 265 | $ [ "packages: " ++ srcDir ++ "/" 266 | ] 267 | | otherwise = do 268 | writeFile "cabal.project" 269 | $ unlines 270 | $ [ "packages: " 271 | , " " ++ srcDir ++ "/" 272 | , " " ++ depFile ++ "/" 273 | ] 274 | 275 | serialiseToFile :: ToJSON a => FilePath -> a -> IO () 276 | serialiseToFile path a = 277 | Yaml.encodeFile path a 278 | 279 | streamSep :: Monad m => B.ByteString -> Stream (Of B.ByteString) m r -> Stream (Of B.ByteString) m r 280 | streamSep sep = go 281 | where 282 | go s0 = do 283 | e <- lift (S.next s0) 284 | case e of 285 | Left r -> do 286 | pure r 287 | Right (a, rest) -> do 288 | S.yield a 289 | prependToAll rest 290 | prependToAll s = do 291 | e <- lift (S.next s) 292 | case e of 293 | Left r -> do 294 | pure r 295 | Right (a, rest) -> do 296 | S.yield sep 297 | S.yield a 298 | prependToAll rest 299 | 300 | exitCodeToInt :: ExitCode -> Int 301 | exitCodeToInt = \case 302 | ExitSuccess -> 0 303 | ExitFailure i -> i 304 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveAnyClass #-} 2 | {-# language DeriveGeneric #-} 3 | {-# language DerivingStrategies #-} 4 | {-# language DuplicateRecordFields #-} 5 | {-# language LambdaCase #-} 6 | {-# language RecordWildCards #-} 7 | {-# language TypeApplications #-} 8 | 9 | {-# options_ghc -fno-warn-orphans #-} 10 | 11 | module Types 12 | ( BuildMatrix(..) 13 | , PackageSource(..) 14 | , PatchFile 15 | , BuildReport(..) 16 | , Phase(..) 17 | 18 | , sourcePackage 19 | , sourceVersion 20 | ) where 21 | 22 | import Data.Aeson (ToJSON(..), FromJSON(..)) 23 | import Data.Text (Text) 24 | import Distribution.Package (PackageName) 25 | import Distribution.Version (Version) 26 | import GHC.Generics (Generic) 27 | import PackDeps () 28 | import System.Exit (ExitCode(..)) 29 | import qualified Data.Aeson as Aeson 30 | import qualified Data.Scientific as Scientific 31 | 32 | data BuildMatrix = BuildMatrix 33 | { packageSrc :: PackageSource 34 | , patches :: Maybe [PatchFile] 35 | , dependencies :: [PackageSource] 36 | } 37 | deriving stock (Eq, Show, Generic) 38 | deriving anyclass (ToJSON, FromJSON) 39 | 40 | data PackageSource 41 | = HackageGet 42 | { package :: PackageName 43 | , version :: Version 44 | } 45 | | FetchFromGitHub 46 | { package :: PackageName 47 | , owner :: String 48 | , repo :: String 49 | , rev :: Maybe String 50 | , subPath :: Maybe FilePath 51 | } 52 | deriving stock (Eq, Show, Generic) 53 | deriving anyclass (ToJSON, FromJSON) 54 | 55 | sourcePackage :: PackageSource -> PackageName 56 | sourcePackage = \case 57 | HackageGet{..} -> package 58 | FetchFromGitHub{..} -> package 59 | 60 | sourceVersion :: PackageSource -> Maybe Version 61 | sourceVersion = \case 62 | HackageGet{..} -> Just version 63 | FetchFromGitHub{} -> Nothing 64 | 65 | type PatchFile = FilePath 66 | 67 | data Phase = Fetching | Building | Testing 68 | deriving stock (Eq, Show, Generic) 69 | deriving anyclass (ToJSON, FromJSON) 70 | 71 | data BuildReport = BuildReport 72 | { pkg :: PackageName 73 | , version :: Maybe Version 74 | , phase :: Phase 75 | , exitCode :: ExitCode 76 | , stdout :: Text 77 | , stderr :: Text 78 | } 79 | deriving stock (Eq, Show, Generic) 80 | deriving anyclass (ToJSON, FromJSON) 81 | 82 | instance ToJSON ExitCode where 83 | toJSON = \case 84 | ExitSuccess -> toJSON @Int 0 85 | ExitFailure n -> toJSON n 86 | 87 | instance FromJSON ExitCode where 88 | parseJSON = Aeson.withScientific "ExitCode" $ \s -> case Scientific.toBoundedInteger s of 89 | Nothing -> fail "not a bounded Int" 90 | Just 0 -> pure ExitSuccess 91 | Just n -> pure (ExitFailure n) 92 | --------------------------------------------------------------------------------