nixpkgs-update 0.2.0 → 0.3.0
raw patch · 36 files changed
+4975/−1244 lines, 36 filesdep +aesondep +bytestringdep +conduitdep −regex-applicativedep −shellydep ~basedep ~directorydep ~neat-interpolationsetup-changed
Dependencies added: aeson, bytestring, conduit, containers, cryptohash-sha256, hspec, hspec-discover, http-client, http-client-tls, http-conduit, http-types, iso8601-time, lifted-base, nixpkgs-update, parsec, parsers, partial-order, polysemy, polysemy-plugin, regex-applicative-text, servant, servant-client, sqlite-simple, template-haskell, temporary, th-env, transformers, typed-process, unordered-containers, versions, xdg-basedir, zlib
Dependencies removed: regex-applicative, shelly
Dependency ranges changed: base, directory, neat-interpolation, time
Files
- LICENSE +121/−1
- README.md +275/−15
- Setup.hs +0/−2
- app/Main.hs +167/−0
- nixpkgs-update.cabal +186/−29
- src/Blacklist.hs +0/−142
- src/CVE.hs +336/−0
- src/Check.hs +241/−98
- src/Clean.hs +0/−115
- src/Data/Hex.hs +76/−0
- src/DeleteMerged.hs +22/−45
- src/File.hs +55/−15
- src/GH.hs +183/−83
- src/Git.hs +213/−75
- src/Main.hs +0/−55
- src/NVD.hs +342/−0
- src/NVDRules.hs +68/−0
- src/Nix.hs +327/−150
- src/NixpkgsReview.hs +64/−0
- src/OurPrelude.hs +125/−0
- src/Outpaths.hs +138/−24
- src/Process.hs +42/−0
- src/Repology.hs +209/−0
- src/Rewrite.hs +274/−0
- src/Skiplist.hs +186/−0
- src/Time.hs +60/−0
- src/Update.hs +597/−250
- src/Utils.hs +252/−142
- src/Version.hs +243/−0
- test/CheckSpec.hs +27/−0
- test/DoctestSpec.hs +33/−0
- test/RewriteSpec.hs +42/−0
- test/Spec.hs +1/−0
- test/UpdateSpec.hs +51/−0
- test/UtilsSpec.hs +19/−0
- test/doctests.hs +0/−3
LICENSE view
@@ -1,1 +1,121 @@-To the extent possible under law, Ryan Mulligan has waived all copyright and related or neighboring rights to repology-api. This work is published from: United States.+Creative Commons Legal Code++CC0 1.0 Universal++ CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE+ LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN+ ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS+ INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES+ REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS+ PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM+ THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED+ HEREUNDER.++Statement of Purpose++The laws of most jurisdictions throughout the world automatically confer+exclusive Copyright and Related Rights (defined below) upon the creator+and subsequent owner(s) (each and all, an "owner") of an original work of+authorship and/or a database (each, a "Work").++Certain owners wish to permanently relinquish those rights to a Work for+the purpose of contributing to a commons of creative, cultural and+scientific works ("Commons") that the public can reliably and without fear+of later claims of infringement build upon, modify, incorporate in other+works, reuse and redistribute as freely as possible in any form whatsoever+and for any purposes, including without limitation commercial purposes.+These owners may contribute to the Commons to promote the ideal of a free+culture and the further production of creative, cultural and scientific+works, or to gain reputation or greater distribution for their Work in+part through the use and efforts of others.++For these and/or other purposes and motivations, and without any+expectation of additional consideration or compensation, the person+associating CC0 with a Work (the "Affirmer"), to the extent that he or she+is an owner of Copyright and Related Rights in the Work, voluntarily+elects to apply CC0 to the Work and publicly distribute the Work under its+terms, with knowledge of his or her Copyright and Related Rights in the+Work and the meaning and intended legal effect of CC0 on those rights.++1. Copyright and Related Rights. A Work made available under CC0 may be+protected by copyright and related or neighboring rights ("Copyright and+Related Rights"). Copyright and Related Rights include, but are not+limited to, the following:++ i. the right to reproduce, adapt, distribute, perform, display,+ communicate, and translate a Work;+ ii. moral rights retained by the original author(s) and/or performer(s);+iii. publicity and privacy rights pertaining to a person's image or+ likeness depicted in a Work;+ iv. rights protecting against unfair competition in regards to a Work,+ subject to the limitations in paragraph 4(a), below;+ v. rights protecting the extraction, dissemination, use and reuse of data+ in a Work;+ vi. database rights (such as those arising under Directive 96/9/EC of the+ European Parliament and of the Council of 11 March 1996 on the legal+ protection of databases, and under any national implementation+ thereof, including any amended or successor version of such+ directive); and+vii. other similar, equivalent or corresponding rights throughout the+ world based on applicable law or treaty, and any national+ implementations thereof.++2. Waiver. To the greatest extent permitted by, but not in contravention+of, applicable law, Affirmer hereby overtly, fully, permanently,+irrevocably and unconditionally waives, abandons, and surrenders all of+Affirmer's Copyright and Related Rights and associated claims and causes+of action, whether now known or unknown (including existing as well as+future claims and causes of action), in the Work (i) in all territories+worldwide, (ii) for the maximum duration provided by applicable law or+treaty (including future time extensions), (iii) in any current or future+medium and for any number of copies, and (iv) for any purpose whatsoever,+including without limitation commercial, advertising or promotional+purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each+member of the public at large and to the detriment of Affirmer's heirs and+successors, fully intending that such Waiver shall not be subject to+revocation, rescission, cancellation, termination, or any other legal or+equitable action to disrupt the quiet enjoyment of the Work by the public+as contemplated by Affirmer's express Statement of Purpose.++3. Public License Fallback. Should any part of the Waiver for any reason+be judged legally invalid or ineffective under applicable law, then the+Waiver shall be preserved to the maximum extent permitted taking into+account Affirmer's express Statement of Purpose. In addition, to the+extent the Waiver is so judged Affirmer hereby grants to each affected+person a royalty-free, non transferable, non sublicensable, non exclusive,+irrevocable and unconditional license to exercise Affirmer's Copyright and+Related Rights in the Work (i) in all territories worldwide, (ii) for the+maximum duration provided by applicable law or treaty (including future+time extensions), (iii) in any current or future medium and for any number+of copies, and (iv) for any purpose whatsoever, including without+limitation commercial, advertising or promotional purposes (the+"License"). The License shall be deemed effective as of the date CC0 was+applied by Affirmer to the Work. Should any part of the License for any+reason be judged legally invalid or ineffective under applicable law, such+partial invalidity or ineffectiveness shall not invalidate the remainder+of the License, and in such case Affirmer hereby affirms that he or she+will not (i) exercise any of his or her remaining Copyright and Related+Rights in the Work or (ii) assert any associated claims and causes of+action with respect to the Work, in either case contrary to Affirmer's+express Statement of Purpose.++4. Limitations and Disclaimers.++ a. No trademark or patent rights held by Affirmer are waived, abandoned,+ surrendered, licensed or otherwise affected by this document.+ b. Affirmer offers the Work as-is and makes no representations or+ warranties of any kind concerning the Work, express, implied,+ statutory or otherwise, including without limitation warranties of+ title, merchantability, fitness for a particular purpose, non+ infringement, or the absence of latent or other defects, accuracy, or+ the present or absence of errors, whether or not discoverable, all to+ the greatest extent permissible under applicable law.+ c. Affirmer disclaims responsibility for clearing rights of other persons+ that may apply to the Work or any use thereof, including without+ limitation any person's Copyright and Related Rights in the Work.+ Further, Affirmer disclaims responsibility for obtaining any necessary+ consents, permissions or other rights required for any use of the+ Work.+ d. Affirmer understands and acknowledges that Creative Commons is not a+ party to this document and has no duty or obligation with respect to+ this CC0 or use of the Work.
README.md view
@@ -1,24 +1,284 @@ # nixpkgs-update -[](https://travis-ci.org/ryantm/nixpkgs-update)+[](https://github.com/ryantm/nixpkgs-update/actions)+[](https://www.patreon.com/nixpkgsupdate) -Scripts to try to update nixpkgs packages. Uses `hub` to automatically make PRs.+> The future is here; let's evenly distribute it! -# Instructions+# Contents -1. Clone this repo and build the tool:- ```+* [Introduction](#introduction)+* [Interactive updates](#interactive-updates)+* [Batch updates](#batch-updates)+* [Details](#details)+* [Development](#development)++# Introduction++The [nixpkgs-update](https://github.com/ryantm/nixpkgs-update) mission+is to make [nixpkgs](https://github.com/nixos/nixpkgs) the most+up-to-date repository of software in the world by the most ridiculous+margin possible. [Here's how we are doing so far](https://repology.org/repositories/graphs).++It provides an interactive tool for automating single package+updates. Given a package name, old version, and new version, it+updates the version, and fetcher hashes, makes a commit, and+optionally a pull request. Along the way, it does checks to make sure+the update has a baseline quality.++It is the code used by the GitHub bot+[@r-ryantm](https://github.com/r-ryantm) to automatically update+nixpkgs. It uses package repository information from+[Repology.org](https://repology.org/repository/nix_unstable), the+GitHub releases API, and PyPI to generate a lists of outdated+packages.++# Installation++For the Cachix cache to work, your user must be in the trusted-users+list or you can use sudo since root is effectively trusted.++Run without installing:++```bash+nix run \+ --option extra-substituters 'https://nixpkgs-update.cachix.org/' \+ --option trusted-public-keys 'nixpkgs-update.cachix.org-1:6y6Z2JdoL3APdu6/+Iy8eZX2ajf09e4EE9SnxSML1W8=' \+ -f https://github.com/ryantm/nixpkgs-update/archive/master.tar.gz \+ -c nixpkgs-update --help+```++Install into your Nix profile:++```bash+nix-env \+ --option extra-substituters 'https://nixpkgs-update.cachix.org/' \+ --option trusted-public-keys 'nixpkgs-update.cachix.org-1:6y6Z2JdoL3APdu6/+Iy8eZX2ajf09e4EE9SnxSML1W8=' \+ -if https://github.com/ryantm/nixpkgs-update/archive/master.tar.gz+```++Declaratively with [niv](https://github.com/nmattia/niv):++```bash+niv add ryantm/nixpkgs-update+```++NixOS config with Niv:++```nix+let+ sources = import ./nix/sources.nix;+ nixpkgs-update = import sources.nixpkgs-update {};+in+ environment.systemPackages = [ nixpkgs-update ];+```++home-manager config with Niv:++```nix+let+ sources = import ./nix/sources.nix;+ nixpkgs-update = import sources.nixpkgs-update {};+in+ home.packages = [ nixpkgs-update ];+```++# Interactive updates++nixpkgs-update supports interactive, single package updates via the+`update` subcommand.++# Update tutorial++1. Setup [hub](https://github.com/github/hub) and give it your GitHub+ credentials, so it saves an oauth token. This allows nixpkgs-update+ to query the GitHub API.+2. Go to your local checkout of nixpkgs, and **make sure the working+ directory is clean**. Be on a branch you are okay committing to.+3. Run it like: `nixpkgs-update update "postman 7.20.0 7.21.2"`+ which mean update the package "postman" from version 7.20.0+ to version 7.21.2.+4. It will run the updater, and, if the update builds, it will commit+ the update and output a message you could use for a pull request.++# Flags++* `--cve`—adds CVE vulnerability reporting to the PR message. On+ first invocation with this option, a CVE database is+ built. Subsequent invocations will be much faster.+* `--nixpkgs-review`—runs+ [nixpkgs-review](https://github.com/Mic92/nixpkgs-review), which+ tries to build all the packages that depend on the one being updated+ and adds a report.++# Batch updates++nixpkgs-update supports batch updates via the `update-list`+subcommand.++## Update-List tutorial++1. Setup [hub](https://github.com/github/hub) and give it your GitHub+ credentials, so it saves an oauth token. This allows nixpkgs-update+ to query the GitHub API.++2. Clone this repository and build `nixpkgs-update`:+ ```bash git clone https://github.com/ryantm/nixpkgs-update && cd nixpkgs-update- nix run nixpkgs.cabal2nix -c cabal2nix --shell --hpack . > shell.nix && nix-build shell.nix- ```-2. Get a list of oudated packages and place them in a `packages-to-update.txt` file in the root directory of this repository.- ```- git clone https://github.com/ryantm/repology-api.git && cd repology-api- nix run nixpkgs.cabal2nix -c cabal2nix --shell --hpack . > shell.nix && nix-build shell.nix && result/bin/repology-api > ../packages-to-update.txt+ nix-build ```-3. Return back `cd ..` and run the tool `nix run -f '<nixpkgs>' gitAndTools.hub gist jq tree -c result/bin/nixpkgs-update --update` -# Prior work+3. To test your config, try to update a single package, like this: -* https://github.com/NixOS/nixpkgs/blob/master/pkgs/common-updater/scripts/update-source-version-* https://github.com/NixOS/nixpkgs/tree/master/pkgs/build-support/upstream-updater+ ```bash+ ./result/bin/nixpkgs-update update "pkg oldVer newVer update-page"`++ # Example:+ ./result/bin/nixpkgs-update update "tflint 0.15.0 0.15.1 repology.org"`+ ```++ replacing `tflint` with the attribute name of the package you actually want+ to update, and the old version and new version accordingly.++ If this works, you are now setup to hack on `nixpkgs-update`! If+ you run it with `--pr`, it will actually send a pull request, which+ looks like this: https://github.com/NixOS/nixpkgs/pull/82465+++4. If you'd like to send a batch of updates, get a list of outdated packages and+ place them in a `packages-to-update.txt` file:++ ```bash+ ./result/bin/nixpkgs-update fetch-repology > packages-to-update.txt+ ```++ There also exist alternative sources of updates, these include:++ - PyPI, the Python Package Index:+ [nixpkgs-update-pypi-releases](https://github.com/jonringer/nixpkgs-update-pypi-releases)+ - GitHub releases:+ [nixpkgs-update-github-releases](https://github.com/synthetica9/nixpkgs-update-github-releases)++5. Run the tool in batch mode with `update-list`:++ ```bash+ ./result/bin/nixpkgs-update update-list+ ```++# Details++Some of these features only apply to the update-list sub-command or to+features only available to the @r-ryantm bot.++## Checks++A number of checks are performed to help nixpkgs maintainers gauge the+likelihood that an update was successful. All the binaries are run with+various flags to see if they have a zero exit code and output the new+version number. The outpath directory tree is searched for files+containing the new version number. A directory tree and disk usage+listing is provided.+++## Security report++Information from the National Vulnerability Database maintained by+NIST is compared against the current and updated package version. The+nixpkgs package name is matched with the Common Platform Enumeration+vendor, product, edition, software edition, and target software fields+to find candidate Common Vulnerabilities and Exposures (CVEs). The+CVEs are filtered by the matching the current and updated versions+with the CVE version ranges.++The general philosophy of the CVE search is to avoid false negatives,+which means we expect to generate many false positives. The false+positives can be carefully removed by manually created rules+implemented in the filter function in the NVDRules module.++If there are no CVE matches, the report is not shown. The report has+three parts: CVEs resolved by this update, CVEs introduced by this+update, and CVEs present in both version.++If you would like to report a problem with the security report, please+use the [nixpkgs-update GitHub+issues](https://github.com/ryantm/nixpkgs-update/issues).++The initial development of the security report was made possible by a+partnership with [Serokell](https://serokell.io/) and the [NLNet+Foundation](https://nlnet.nl/) through their [Next Generation Internet+Zero Discovery initiative](https://nlnet.nl/discovery/) (NGI0+Discovery). NGI0 Discovery is made possible with financial support+from the [European Commission](https://ec.europa.eu/).+++## Rebuild report++The PRs made by nixpkgs-update say what packages need to be rebuilt if+the pull request is merged. This uses the same mechanism+[OfBorg](https://github.com/NixOS/ofborg) uses to put rebuild labels+on PRs. Not limited by labels, it can report the exact number of+rebuilds and list some of the attrpaths that would need to be rebuilt.+++## PRs against staging++If a PR merge would cause more than 100 packages to be rebuilt, the PR+is made against staging.+++## Logs++[Logs from r-ryantm's runs](https://r.ryantm.com/log/) are+available online. There are a lot of packages `nixpkgs-update`+currently has no hope of updating. Please dredge the logs to find out+why your pet package is not receiving updates.+++## Cachix++By uploading the build outputs to+[Cachix](https://nix-community.cachix.org/), nixpkgs-update allows you to+test a package with one command.+++# Development++Incremental development:++```bash+nix-shell --run "cabal v2-repl"+```++Run the tests:++```bash+nix-shell --run "cabal v2-test"+```++Run a type checker in the background for quicker type checking feedback:++```bash+nix-shell --run "ghcid"+```++Run a type checker for the app code:++```bash+nix-shell --run 'ghcid -c "cabal v2-repl exe:nixpkgs-update"'+```++Run a type checker for the test code:++```bash+nix-shell --run 'ghcid -c "cabal v2-repl tests"'+```++Updating the Cabal file when adding new dependencies or options:++```bash+nix run nixpkgs.haskellPackages.hpack -c hpack+```++Source files are formatted with [Ormolu](https://github.com/tweag/ormolu).++There is also a [Cachix cache](https://nixpkgs-update.cachix.org/) available for the dependencies of this program.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Main where++import Control.Applicative ((<**>))+import qualified Data.Text as T+import qualified Data.Text.IO as T+import DeleteMerged (deleteDone)+import Git+import NVD (withVulnDB)+import qualified Nix+import qualified Options.Applicative as O+import OurPrelude+import qualified Repology+import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)+import qualified System.Posix.Env as P+import Update (cveAll, cveReport, sourceGithubAll, updateAll, updatePackage)+import Utils (Options (..), UpdateEnv (..), getGithubToken, getGithubUser)++default (T.Text)++data UpdateOptions = UpdateOptions+ { pr :: Bool,+ cve :: Bool,+ nixpkgsReview :: Bool,+ outpaths :: Bool+ }++data Command+ = UpdateList UpdateOptions+ | Update UpdateOptions Text+ | DeleteDone Bool+ | Version+ | UpdateVulnDB+ | CheckAllVulnerable+ | SourceGithub+ | FetchRepology+ | CheckVulnerable Text Text Text++updateOptionsParser :: O.Parser UpdateOptions+updateOptionsParser =+ UpdateOptions+ <$> O.flag False True (O.long "pr" <> O.help "Make a pull request using Hub.")+ <*> O.flag False True (O.long "cve" <> O.help "Make a CVE vulnerability report.")+ <*> O.flag False True (O.long "nixpkgs-review" <> O.help "Runs nixpkgs-review on update commit rev")+ <*> O.flag False True (O.long "outpaths" <> O.help "Calculate outpaths to determine the branch to target")++updateParser :: O.Parser Command+updateParser =+ Update+ <$> updateOptionsParser+ <*> O.strArgument (O.metavar "UPDATE_INFO" <> O.help "update string of the form: 'pkg oldVer newVer update-page'\n\n example: 'tflint 0.15.0 0.15.1 repology.org'")++deleteDoneParser :: O.Parser Command+deleteDoneParser =+ DeleteDone+ <$> O.flag False True (O.long "delete" <> O.help "Actually delete the done branches. Otherwise just prints the branches to delete.")++commandParser :: O.Parser Command+commandParser =+ O.hsubparser+ ( O.command+ "update-list"+ (O.info (UpdateList <$> updateOptionsParser) (O.progDesc "Update a list of packages"))+ <> O.command+ "update"+ (O.info (updateParser) (O.progDesc "Update one package"))+ <> O.command+ "delete-done"+ ( O.info+ deleteDoneParser+ (O.progDesc "Deletes branches from PRs that were merged or closed")+ )+ <> O.command+ "version"+ ( O.info+ (pure Version)+ ( O.progDesc+ "Displays version information for nixpkgs-update and dependencies"+ )+ )+ <> O.command+ "update-vulnerability-db"+ ( O.info+ (pure UpdateVulnDB)+ (O.progDesc "Updates the vulnerability database")+ )+ <> O.command+ "check-vulnerable"+ (O.info checkVulnerable (O.progDesc "checks if something is vulnerable"))+ <> O.command+ "check-all-vulnerable"+ ( O.info+ (pure CheckAllVulnerable)+ (O.progDesc "checks all packages to update for vulnerabilities")+ )+ <> O.command+ "source-github"+ (O.info (pure SourceGithub) (O.progDesc "looks for updates on GitHub"))+ <> O.command+ "fetch-repology"+ (O.info (pure FetchRepology) (O.progDesc "fetches update from Repology and prints them to stdout"))+ )++checkVulnerable :: O.Parser Command+checkVulnerable =+ CheckVulnerable <$> O.strArgument (O.metavar "PRODUCT_ID")+ <*> O.strArgument (O.metavar "OLD_VERSION")+ <*> O.strArgument (O.metavar "NEW_VERSION")++programInfo :: O.ParserInfo Command+programInfo =+ O.info+ (commandParser <**> O.helper)+ ( O.fullDesc+ <> O.progDesc "Update packages in the Nixpkgs repository"+ <> O.header "nixpkgs-update"+ )++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering+ command <- O.execParser programInfo+ ghUser <- getGithubUser+ token <- getGithubToken <|> undefined+ P.setEnv "GITHUB_TOKEN" (T.unpack token) True+ P.setEnv "GITHUB_API_TOKEN" (T.unpack token) True+ P.setEnv "PAGER" "" True+ case command of+ DeleteDone delete -> do+ Git.setupNixpkgs token+ deleteDone delete token ghUser+ UpdateList UpdateOptions {pr, cve, nixpkgsReview, outpaths} -> do+ updates <- T.readFile "packages-to-update.txt"+ Git.setupNixpkgs token+ updateAll (Options pr True ghUser token cve nixpkgsReview outpaths) updates+ Update UpdateOptions {pr, cve, nixpkgsReview} update -> do+ Git.setupNixpkgs token+ result <- updatePackage (Options pr False ghUser token cve nixpkgsReview False) update+ case result of+ Left e -> T.putStrLn e+ Right () -> T.putStrLn "Done."+ Version -> do+ v <- runExceptT Nix.version+ case v of+ Left t -> T.putStrLn ("error:" <> t)+ Right t -> T.putStrLn t+ UpdateVulnDB -> withVulnDB $ \_conn -> pure ()+ CheckAllVulnerable -> do+ setupNixpkgs undefined+ updates <- T.readFile "packages-to-update.txt"+ cveAll undefined updates+ CheckVulnerable productID oldVersion newVersion -> do+ setupNixpkgs undefined+ report <-+ cveReport+ (UpdateEnv productID oldVersion newVersion Nothing (Options False False ghUser token False False False))+ T.putStrLn report+ SourceGithub -> do+ updates <- T.readFile "packages-to-update.txt"+ setupNixpkgs token+ sourceGithubAll (Options False False ghUser token False False False) updates+ FetchRepology -> Repology.fetch
nixpkgs-update.cabal view
@@ -1,23 +1,24 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: dbfac301b2851ef0eb87cd2dc7989a2970db94cdaa891199031c4115cbb6f01c+-- hash: 6778c17aab195efecb532625c1155500d873a35ed7db9bd27fe86cb841a65bd4 name: nixpkgs-update-version: 0.2.0+version: 0.3.0 synopsis: Tool for semi-automatic updating of nixpkgs repository description: nixpkgs-update provides tools for updating of nixpkgs packages in a semi-automatic way. Mainly, it is used to run the GitHub bot @r-ryantm, but the underlying update mechanisms should be generally useful and in a later version should be exposed as a command-line tool. category: Web homepage: https://github.com/ryantm/nixpkgs-update#readme bug-reports: https://github.com/ryantm/nixpkgs-update/issues-author: Ryan Mulligan+author: Ryan Mulligan et al. maintainer: ryan@ryantm.com-copyright: 2018 Ryan Mulligan-license: PublicDomain+copyright: 2018-2020 Ryan Mulligan et al.+license: CC0-1.0 license-file: LICENSE build-type: Simple-cabal-version: >= 1.10 extra-source-files: README.md @@ -25,62 +26,218 @@ type: git location: https://github.com/ryantm/nixpkgs-update -executable nixpkgs-update- main-is: Main.hs- other-modules:- Blacklist+library+ exposed-modules: Check- Clean+ CVE+ Data.Hex DeleteMerged File GH Git Nix+ NixpkgsReview+ NVD+ NVDRules+ OurPrelude Outpaths+ Process+ Repology+ Rewrite+ Skiplist+ Time Update Utils- Paths_nixpkgs_update+ Version hs-source-dirs: src+ default-extensions:+ DataKinds+ FlexibleContexts+ GADTs+ LambdaCase+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ BlockArguments+ ghc-options: -Wall -O2 -flate-specialise -fspecialise-aggressively -fplugin=Polysemy.Plugin build-depends:- base >=4.7 && <5- , directory >=1.3 && <1.4+ aeson+ , base >=4.13 && <5+ , bytestring+ , conduit+ , containers+ , cryptohash-sha256+ , directory , errors , filepath , github+ , http-client+ , http-client-tls+ , http-conduit+ , http-types+ , iso8601-time+ , lifted-base , mtl- , neat-interpolation >=0.3 && <0.4+ , neat-interpolation , optparse-applicative- , regex-applicative- , shelly+ , parsec+ , parsers+ , partial-order+ , polysemy+ , polysemy-plugin+ , regex-applicative-text+ , servant+ , servant-client+ , sqlite-simple+ , template-haskell+ , temporary , text- , time >=1.8 && <1.10+ , th-env+ , time+ , transformers+ , typed-process , unix+ , unordered-containers , vector+ , versions+ , xdg-basedir+ , zlib default-language: Haskell2010 -test-suite doctests+executable nixpkgs-update+ main-is: Main.hs+ hs-source-dirs:+ app+ default-extensions:+ DataKinds+ FlexibleContexts+ GADTs+ LambdaCase+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ BlockArguments+ ghc-options: -Wall -O2 -flate-specialise -fspecialise-aggressively -fplugin=Polysemy.Plugin+ build-depends:+ aeson+ , base >=4.13 && <5+ , bytestring+ , conduit+ , containers+ , cryptohash-sha256+ , directory+ , errors+ , filepath+ , github+ , http-client+ , http-client-tls+ , http-conduit+ , http-types+ , iso8601-time+ , lifted-base+ , mtl+ , neat-interpolation+ , nixpkgs-update+ , optparse-applicative+ , parsec+ , parsers+ , partial-order+ , polysemy+ , polysemy-plugin+ , regex-applicative-text+ , servant+ , servant-client+ , sqlite-simple+ , template-haskell+ , temporary+ , text+ , th-env+ , time+ , transformers+ , typed-process+ , unix+ , unordered-containers+ , vector+ , versions+ , xdg-basedir+ , zlib+ default-language: Haskell2010++test-suite spec type: exitcode-stdio-1.0- main-is: doctests.hs+ main-is: Spec.hs other-modules:- Paths_nixpkgs_update+ CheckSpec+ DoctestSpec+ RewriteSpec+ UpdateSpec+ UtilsSpec hs-source-dirs: test- ghc-options: -threaded+ default-extensions:+ DataKinds+ FlexibleContexts+ GADTs+ LambdaCase+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ BlockArguments+ ghc-options: -Wall -O2 -flate-specialise -fspecialise-aggressively -fplugin=Polysemy.Plugin build-depends:- base >=4.7 && <5- , directory >=1.3 && <1.4+ aeson+ , base >=4.13 && <5+ , bytestring+ , conduit+ , containers+ , cryptohash-sha256+ , directory , doctest , errors , filepath , github+ , hspec+ , hspec-discover+ , http-client+ , http-client-tls+ , http-conduit+ , http-types+ , iso8601-time+ , lifted-base , mtl- , neat-interpolation >=0.3 && <0.4+ , neat-interpolation+ , nixpkgs-update , optparse-applicative- , regex-applicative- , shelly+ , parsec+ , parsers+ , partial-order+ , polysemy+ , polysemy-plugin+ , regex-applicative-text+ , servant+ , servant-client+ , sqlite-simple+ , template-haskell+ , temporary , text- , time >=1.8 && <1.10+ , th-env+ , time+ , transformers+ , typed-process , unix+ , unordered-containers , vector+ , versions+ , xdg-basedir+ , zlib default-language: Haskell2010
− src/Blacklist.hs
@@ -1,142 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Blacklist- ( packageName- , content- , srcUrl- , attrPath- , checkResult- ) where--import Data.Foldable (find)-import Data.Text (Text)-import qualified Data.Text as T--type Blacklist = [(Text -> Bool, Text)]--srcUrl :: Text -> Either Text ()-srcUrl = blacklister srcUrlList--attrPath :: Text -> Either Text ()-attrPath = blacklister attrPathList--packageName :: Text -> Either Text ()-packageName name =- if (name == "elementary-xfce-icon-theme") -- https://github.com/ryantm/nixpkgs-update/issues/63- then Right ()- else blacklister nameList name--content :: Text -> Either Text ()-content = blacklister contentList--checkResult :: Text -> Either Text ()-checkResult = blacklister checkResultList--srcUrlList :: Blacklist-srcUrlList =- [(("gnome" `T.isInfixOf`), "Packages from gnome are currently blacklisted.")]--attrPathList :: Blacklist-attrPathList =- [ prefix- "lua"- "Packages for lua are currently blacklisted. https://github.com/NixOS/nixpkgs/pull/37501#issuecomment-375169646"- , prefix "lxqt" "Packages for lxqt are currently blacklisted."- , prefix- "altcoins.bitcoin-xt"- "nix-prefetch-url has infinite redirect https://github.com/NixOS/nix/issues/2225 remove after Nix upgrade that includes https://github.com/NixOS/nix/commit/b920b908578d68c7c80f1c1e89c42784693e18d5."- , prefix- "altcoins.bitcoin"- "@roconnor asked for a blacklist on this until something can be done with GPG signatures https://github.com/NixOS/nixpkgs/commit/77f3ac7b7638b33ab198330eaabbd6e0a2e751a9"- , eq "sqlite-interactive" "it is an override"- , eq "harfbuzzFull" "it is an override"- ]--nameList :: Blacklist-nameList =- [ prefix "r-" "we don't know how to find the attrpath for these"- , infixOf "jquery" "this isn't a real package"- , infixOf "google-cloud-sdk" "complicated package"- , infixOf "github-release" "complicated package"- , infixOf- "libxc"- "currently people don't want to update this https://github.com/NixOS/nixpkgs/pull/35821"- , infixOf "perl" "currently don't know how to update perl"- , infixOf "python" "currently don't know how to update python"- , infixOf "cdrtools" "We keep downgrading this by accident."- , infixOf "gst" "gstreamer plugins are kept in lockstep."- , infixOf "electron" "multi-platform srcs in file."- , infixOf- "linux-headers"- "Not updated until many packages depend on it (part of stdenv)."- , infixOf "xfce" "@volth asked to not update xfce"- , infixOf "cmake-cursesUI-qt4UI" "Derivation file is complicated"- , infixOf "iana-etc" "@mic92 takes care of this package"- , infixOf- "checkbashism"- "needs to be fixed, see https://github.com/NixOS/nixpkgs/pull/39552"- , eq "isl" "multi-version long building package"- , infixOf "qscintilla" "https://github.com/ryantm/nixpkgs-update/issues/51"- , eq "itstool" "https://github.com/NixOS/nixpkgs/pull/41339"- , eq- "wire-desktop"- "nixpkgs-update cannot handle this derivation https://github.com/NixOS/nixpkgs/pull/42936#issuecomment-402282692"- , infixOf- "virtualbox"- "nixpkgs-update cannot handle updating the guest additions https://github.com/NixOS/nixpkgs/pull/42934"- , eq- "avr-binutils"- "https://github.com/NixOS/nixpkgs/pull/43787#issuecomment-408649537"- , eq- "iasl"- "two updates had to be reverted, https://github.com/NixOS/nixpkgs/pull/46272"- , eq- "meson"- "https://github.com/NixOS/nixpkgs/pull/47024#issuecomment-423300633"- , eq- "burp"- "temporary blacklist until better versioning schema https://github.com/NixOS/nixpkgs/pull/46298#issuecomment-419536301"- ]--contentList :: Blacklist-contentList =- [ infixOf "DO NOT EDIT" "Derivation file says not to edit it."- , infixOf "Do not edit!" "Derivation file says not to edit it."- -- Skip packages that have special builders- , infixOf "buildGoPackage" "Derivation contains buildGoPackage."- , infixOf "buildRustCrate" "Derivation contains buildRustCrate."- , infixOf "buildPythonPackage" "Derivation contains buildPythonPackage."- , infixOf "buildRubyGem" "Derivation contains buildRubyGem."- , infixOf "bundlerEnv" "Derivation contains bundlerEnv."- , infixOf "buildPerlPackage" "Derivation contains buildPerlPackage."- ]--checkResultList :: Blacklist-checkResultList =- [ infixOf- "busybox"- "- busybox result is not automatically checked, because some binaries kill the shell"- , infixOf- "fcitx"- "- fcitx result is not automatically checked, because some binaries gets stuck in daemons"- , infixOf- "x2goclient"- "- x2goclient result is not automatically checked, because some binaries don't timeout properly"- ]--blacklister :: Blacklist -> Text -> Either Text ()-blacklister blacklist input =- case result of- Nothing -> Right ()- Just msg -> Left msg- where- result = snd <$> find (\(isBlacklisted, _) -> isBlacklisted input) blacklist--prefix :: Text -> Text -> (Text -> Bool, Text)-prefix part reason = ((part `T.isPrefixOf`), reason)--infixOf :: Text -> Text -> (Text -> Bool, Text)-infixOf part reason = ((part `T.isInfixOf`), reason)--eq :: Text -> Text -> (Text -> Bool, Text)-eq part reason = ((part ==), reason)
+ src/CVE.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module CVE+ ( parseFeed,+ CPE (..),+ CPEMatch (..),+ CPEMatchRow (..),+ cpeMatches,+ CVE (..),+ CVEID,+ cveLI,+ )+where++import Data.Aeson+ ( FromJSON,+ Object,+ eitherDecode,+ parseJSON,+ withObject,+ (.!=),+ (.:),+ (.:!),+ )+import Data.Aeson.Types (Parser, prependFailure)+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.List (intercalate)+import qualified Data.Text as T+import Data.Time.Clock (UTCTime)+import Database.SQLite.Simple (FromRow, ToRow, field, fromRow, toRow)+import Database.SQLite.Simple.ToField (toField)+import OurPrelude+import Utils (Boundary (..), VersionMatcher (..))++type CVEID = Text++data CVE = CVE+ { cveID :: CVEID,+ cveCPEMatches :: [CPEMatch],+ cveDescription :: Text,+ cvePublished :: UTCTime,+ cveLastModified :: UTCTime+ }+ deriving (Show, Eq, Ord)++-- | cve list item+cveLI :: CVE -> Bool -> Text+cveLI c patched =+ "- ["+ <> cveID c+ <> "](https://nvd.nist.gov/vuln/detail/"+ <> cveID c+ <> ")"+ <> p+ where+ p =+ if patched+ then " (patched)"+ else ""++data CPEMatch = CPEMatch+ { cpeMatchCPE :: CPE,+ cpeMatchVulnerable :: Bool,+ cpeMatchVersionMatcher :: VersionMatcher+ }+ deriving (Show, Eq, Ord)++instance FromRow CPEMatch where+ fromRow = do+ cpeMatchCPE <- fromRow+ let cpeMatchVulnerable = True+ cpeMatchVersionMatcher <- field+ pure CPEMatch {..}++-- This decodes an entire CPE string and related attributes, but we only use+-- cpeVulnerable, cpeProduct, cpeVersion and cpeMatcher.+data CPE = CPE+ { cpePart :: (Maybe Text),+ cpeVendor :: (Maybe Text),+ cpeProduct :: (Maybe Text),+ cpeVersion :: (Maybe Text),+ cpeUpdate :: (Maybe Text),+ cpeEdition :: (Maybe Text),+ cpeLanguage :: (Maybe Text),+ cpeSoftwareEdition :: (Maybe Text),+ cpeTargetSoftware :: (Maybe Text),+ cpeTargetHardware :: (Maybe Text),+ cpeOther :: (Maybe Text)+ }+ deriving (Eq, Ord)++instance Show CPE where+ show+ CPE+ { cpePart,+ cpeVendor,+ cpeProduct,+ cpeVersion,+ cpeUpdate,+ cpeEdition,+ cpeLanguage,+ cpeSoftwareEdition,+ cpeTargetSoftware,+ cpeTargetHardware,+ cpeOther+ } =+ "CPE {"+ <> (intercalate ", " . concat)+ [ cpeField "part" cpePart,+ cpeField "vendor" cpeVendor,+ cpeField "product" cpeProduct,+ cpeField "version" cpeVersion,+ cpeField "update" cpeUpdate,+ cpeField "edition" cpeEdition,+ cpeField "language" cpeLanguage,+ cpeField "softwareEdition" cpeSoftwareEdition,+ cpeField "targetSoftware" cpeTargetSoftware,+ cpeField "targetHardware" cpeTargetHardware,+ cpeField "other" cpeOther+ ]+ <> "}"+ where+ cpeField :: Show a => String -> Maybe a -> [String]+ cpeField _ Nothing = []+ cpeField name (Just value) = [name <> " = " <> show value]++instance ToRow CPE where+ toRow+ CPE+ { cpePart,+ cpeVendor,+ cpeProduct,+ cpeVersion,+ cpeUpdate,+ cpeEdition,+ cpeLanguage,+ cpeSoftwareEdition,+ cpeTargetSoftware,+ cpeTargetHardware,+ cpeOther+ } =+ fmap -- There is no toRow instance for a tuple this large+ toField+ [ cpePart,+ cpeVendor,+ cpeProduct,+ cpeVersion,+ cpeUpdate,+ cpeEdition,+ cpeLanguage,+ cpeSoftwareEdition,+ cpeTargetSoftware,+ cpeTargetHardware,+ cpeOther+ ]++instance FromRow CPE where+ fromRow = do+ cpePart <- field+ cpeVendor <- field+ cpeProduct <- field+ cpeVersion <- field+ cpeUpdate <- field+ cpeEdition <- field+ cpeLanguage <- field+ cpeSoftwareEdition <- field+ cpeTargetSoftware <- field+ cpeTargetHardware <- field+ cpeOther <- field+ pure CPE {..}++-- | Parse a @description_data@ subtree and return the concatenation of the+-- english descriptions.+parseDescription :: Object -> Parser Text+parseDescription o = do+ dData <- o .: "description_data"+ descriptions <-+ fmap concat $+ sequence $+ flip map dData $+ \dDatum -> do+ value <- dDatum .: "value"+ lang :: Text <- dDatum .: "lang"+ pure $+ case lang of+ "en" -> [value]+ _ -> []+ pure $ T.intercalate "\n\n" descriptions++instance FromJSON CVE where+ parseJSON =+ withObject "CVE" $ \o -> do+ cve <- o .: "cve"+ meta <- cve .: "CVE_data_meta"+ cveID <- meta .: "ID"+ prependFailure (T.unpack cveID <> ": ") $ do+ cfgs <- o .: "configurations"+ cveCPEMatches <- parseConfigurations cfgs+ cvePublished <- o .: "publishedDate"+ cveLastModified <- o .: "lastModifiedDate"+ description <- cve .: "description"+ cveDescription <- parseDescription description+ pure CVE {..}++instance ToRow CVE where+ toRow CVE {cveID, cveDescription, cvePublished, cveLastModified} =+ toRow (cveID, cveDescription, cvePublished, cveLastModified)++instance FromRow CVE where+ fromRow = do+ let cveCPEMatches = []+ cveID <- field+ cveDescription <- field+ cvePublished <- field+ cveLastModified <- field+ pure CVE {..}++splitCPE :: Text -> [Maybe Text]+splitCPE =+ map (toMaybe . T.replace "\a" ":") . T.splitOn ":" . T.replace "\\:" "\a"+ where+ toMaybe "*" = Nothing+ toMaybe x = Just x++instance FromJSON CPEMatch where+ parseJSON =+ withObject "CPEMatch" $ \o -> do+ t <- o .: "cpe23Uri"+ cpeMatchCPE <-+ case splitCPE t of+ [Just "cpe", Just "2.3", cpePart, cpeVendor, cpeProduct, cpeVersion, cpeUpdate, cpeEdition, cpeLanguage, cpeSoftwareEdition, cpeTargetSoftware, cpeTargetHardware, cpeOther] ->+ pure CPE {..}+ _ -> fail $ "unparsable cpe23Uri: " <> T.unpack t+ cpeMatchVulnerable <- o .: "vulnerable"+ vStartIncluding <- o .:! "versionStartIncluding"+ vEndIncluding <- o .:! "versionEndIncluding"+ vStartExcluding <- o .:! "versionStartExcluding"+ vEndExcluding <- o .:! "versionEndExcluding"+ startBoundary <-+ case (vStartIncluding, vStartExcluding) of+ (Nothing, Nothing) -> pure Unbounded+ (Just start, Nothing) -> pure (Including start)+ (Nothing, Just start) -> pure (Excluding start)+ (Just _, Just _) -> fail "multiple version starts"+ endBoundary <-+ case (vEndIncluding, vEndExcluding) of+ (Nothing, Nothing) -> pure Unbounded+ (Just end, Nothing) -> pure (Including end)+ (Nothing, Just end) -> pure (Excluding end)+ (Just _, Just _) -> fail "multiple version ends"+ cpeMatchVersionMatcher <-+ case (cpeVersion cpeMatchCPE, startBoundary, endBoundary) of+ (Just v, Unbounded, Unbounded) -> pure $ SingleMatcher v+ (Nothing, start, end) -> pure $ RangeMatcher start end+ _ ->+ fail+ ( "cpe_match has both version "+ <> show (cpeVersion cpeMatchCPE)+ <> " in cpe, and boundaries from "+ <> show startBoundary+ <> " to "+ <> show endBoundary+ )+ pure (CPEMatch {..})++data CPEMatchRow+ = CPEMatchRow CVE CPEMatch++instance ToRow CPEMatchRow where+ toRow (CPEMatchRow CVE {cveID} CPEMatch {cpeMatchCPE, cpeMatchVersionMatcher}) =+ [toField $ Just cveID]+ ++ toRow cpeMatchCPE+ ++ [toField cpeMatchVersionMatcher]++instance FromRow CPEMatchRow where+ fromRow = do+ let cveCPEMatches = []+ let cveDescription = undefined+ let cvePublished = undefined+ let cveLastModified = undefined+ cveID <- field+ cpeM <- fromRow+ pure $ CPEMatchRow (CVE {..}) cpeM++cpeMatches :: [CVE] -> [CPEMatchRow]+cpeMatches = concatMap rows+ where+ rows cve = fmap (CPEMatchRow cve) (cveCPEMatches cve)++guardAttr :: (Eq a, FromJSON a, Show a) => Object -> Text -> a -> Parser ()+guardAttr object attribute expected = do+ actual <- object .: attribute+ unless (actual == expected) $+ fail $+ "unexpected "+ <> T.unpack attribute+ <> ", expected "+ <> show expected+ <> ", got "+ <> show actual++boundedMatcher :: VersionMatcher -> Bool+boundedMatcher (RangeMatcher Unbounded Unbounded) = False+boundedMatcher _ = True++-- Because complex boolean formulas can't be used to determine if a single+-- product/version is vulnerable, we simply use all leaves marked vulnerable.+parseNode :: Object -> Parser [CPEMatch]+parseNode node = do+ maybeChildren <- node .:! "children"+ case maybeChildren of+ Nothing -> do+ matches <- node .:! "cpe_match" .!= []+ pure $+ filter (cpeMatchVersionMatcher >>> boundedMatcher) $+ filter cpeMatchVulnerable matches+ Just children -> do+ fmap concat $ sequence $ map parseNode children++parseConfigurations :: Object -> Parser [CPEMatch]+parseConfigurations o = do+ guardAttr o "CVE_data_version" ("4.0" :: Text)+ nodes <- o .: "nodes"+ fmap concat $ sequence $ map parseNode nodes++parseFeed :: BSL.ByteString -> Either Text [CVE]+parseFeed = bimap T.pack cvefItems . eitherDecode++data CVEFeed = CVEFeed+ { cvefItems :: [CVE]+ }++instance FromJSON CVEFeed where+ parseJSON = withObject "CVEFeed" $ \o -> CVEFeed <$> o .: "CVE_Items"
src/Check.hs view
@@ -1,69 +1,117 @@ {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Check- ( result- ) where+ ( result,+ -- exposed for testing:+ hasVersion+ )+where import Control.Applicative (many)-import Control.Monad (forM)-import Data.Char (isSpace)-import Data.Maybe (isJust)-import Data.Semigroup ((<>))+import Data.Char (isDigit, isLetter)+import Data.Maybe (fromJust) import qualified Data.Text as T-import Data.Text (Text)-import Prelude hiding (FilePath)-import Shelly-import qualified Text.Regex.Applicative as RE-import Text.Regex.Applicative (RE, (=~))-import Utils (Options(..), UpdateEnv (..), Version, canFail, succeded)+import Language.Haskell.TH.Env (envQ)+import OurPrelude+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.Exit+import System.IO.Temp (withSystemTempDirectory)+import Text.Regex.Applicative.Text (RE', (=~))+import qualified Text.Regex.Applicative.Text as RE+import Utils (UpdateEnv (..), Version, nixBuildOptions) default (T.Text) +treeBin :: String+treeBin = fromJust ($$(envQ "TREE") :: Maybe String) <> "/bin/tree"++procTree :: [String] -> ProcessConfig () () ()+procTree = proc treeBin++gistBin :: String+gistBin = fromJust ($$(envQ "GIST") :: Maybe String) <> "/bin/gist"++procGist :: [String] -> ProcessConfig () () ()+procGist = proc gistBin++timeoutBin :: String+timeoutBin = fromJust ($$(envQ "TIMEOUT") :: Maybe String) <> "/bin/timeout"+ data BinaryCheck = BinaryCheck- { filePath :: FilePath- , zeroExitCode :: Bool- , versionPresent :: Bool+ { filePath :: FilePath,+ zeroExitCode :: Bool,+ versionPresent :: Bool } --- | Construct regex: [^\.]*${version}\.*\s*-versionRegex :: Text -> RE Char ()+isWordCharacter :: Char -> Bool+isWordCharacter c = (isDigit c) || (isLetter c)++isNonWordCharacter :: Char -> Bool+isNonWordCharacter c = not (isWordCharacter c)++-- | Construct regex: /.*\b${version}\b.*/s+versionRegex :: Text -> RE' () versionRegex version =- (\_ _ _ _ -> ()) <$> many (RE.psym (/= '.')) <*> RE.string (T.unpack version) <*>- many (RE.sym '.') <*>- many (RE.psym isSpace)+ (\_ -> ()) <$> (+ (((many RE.anySym) <* (RE.psym isNonWordCharacter)) <|> (RE.pure ""))+ *> (RE.string version) <*+ ((RE.pure "") <|> ((RE.psym isNonWordCharacter) *> (many RE.anySym)))+ ) +hasVersion :: Text -> Text -> Bool+hasVersion contents expectedVersion =+ isJust $ contents =~ versionRegex expectedVersion++checkTestsBuild :: Text -> IO Bool+checkTestsBuild attrPath =+ let args =+ nixBuildOptions+ ++ [ "-E",+ "{ config }: (import ./. { inherit config; })."+ ++ (T.unpack attrPath)+ ++ ".tests or {}"+ ]+ in do+ r <- runExceptT $ ourReadProcessInterleaved $ proc "nix-build" args+ case r of+ Right (ExitSuccess, _) -> return True+ _ -> return False+ -- | Run a program with provided argument and report whether the output -- mentions the expected version-checkBinary :: Text -> Version -> FilePath -> Sh BinaryCheck-checkBinary argument expectedVersion program =- catchany_sh- (do- stdout <- canFail $ cmd "timeout" "-k" "2" "1" program argument- code <- lastExitCode- stderr <- lastStderr- let hasVersion =- isJust $ (T.unpack . T.unwords . T.lines $ stdout <> "\n" <> stderr) =~- versionRegex expectedVersion- return $ BinaryCheck program (code == 0) hasVersion)- (\ _ -> return $ BinaryCheck program False False)+checkBinary :: Text -> Version -> FilePath -> IO BinaryCheck+checkBinary argument expectedVersion program = do+ eResult <-+ runExceptT $+ withSystemTempDirectory+ "nixpkgs-update"+ ( ourLockedDownReadProcessInterleaved $+ shell (timeoutBin <> " -k 2 1 " <> program <> " " <> T.unpack argument)+ )+ case eResult of+ Left (_ :: Text) -> return $ BinaryCheck program False False+ Right (exitCode, contents) ->+ return $ BinaryCheck program (exitCode == ExitSuccess) (hasVersion contents expectedVersion) -checks :: [Version -> FilePath -> Sh BinaryCheck]+checks :: [Version -> FilePath -> IO BinaryCheck] checks =- [ checkBinary ""- , checkBinary "-V"- , checkBinary "-v"- , checkBinary "--version"- , checkBinary "version"- , checkBinary "-h"- , checkBinary "--help"- , checkBinary "help"+ [ checkBinary "",+ checkBinary "-V",+ checkBinary "-v",+ checkBinary "--version",+ checkBinary "version",+ checkBinary "-h",+ checkBinary "--help",+ checkBinary "help" ] -someChecks :: BinaryCheck -> [Sh BinaryCheck] -> Sh BinaryCheck+someChecks :: BinaryCheck -> [IO BinaryCheck] -> IO BinaryCheck someChecks best [] = return best-someChecks best (c:rest) = do+someChecks best (c : rest) = do current <- c let nb = newBest current case nb of@@ -73,73 +121,168 @@ newBest :: BinaryCheck -> BinaryCheck newBest (BinaryCheck _ currentExit currentVersionPresent) = BinaryCheck- (filePath best)- (zeroExitCode best || currentExit)- (versionPresent best || currentVersionPresent)+ (filePath best)+ (zeroExitCode best || currentExit)+ (versionPresent best || currentVersionPresent) -- | Run a program with various version or help flags and report -- when they succeded-runChecks :: Version -> FilePath -> Sh BinaryCheck+runChecks :: Version -> FilePath -> IO BinaryCheck runChecks expectedVersion program = someChecks (BinaryCheck program False False) checks' where checks' = map (\c -> c expectedVersion program) checks +checkTestsBuildReport :: Bool -> Text+checkTestsBuildReport False =+ "- Warning: a test defined in `passthru.tests` did not pass"+checkTestsBuildReport True =+ "- The tests defined in `passthru.tests`, if any, passed"+ checkReport :: BinaryCheck -> Text-checkReport (BinaryCheck p False False) = "- Warning: no invocation of " <> toTextIgnore p <> " had a zero exit code or showed the expected version"-checkReport (BinaryCheck p _ _) = "- " <> toTextIgnore p <> " passed the binary check."+checkReport (BinaryCheck p False False) =+ "- Warning: no invocation of "+ <> T.pack p+ <> " had a zero exit code or showed the expected version"+checkReport (BinaryCheck p _ _) =+ "- " <> T.pack p <> " passed the binary check." -successfullCheck :: BinaryCheck -> Bool-successfullCheck (BinaryCheck _ False False) = False-successfullCheck _ = True+ourLockedDownReadProcessInterleaved ::+ MonadIO m =>+ ProcessConfig stdin stdoutIgnored stderrIgnored ->+ FilePath ->+ ExceptT Text m (ExitCode, Text)+ourLockedDownReadProcessInterleaved processConfig tempDir =+ processConfig & setWorkingDir tempDir+ & setEnv [("EDITOR", "echo"), ("HOME", "/we-dont-write-to-home")]+ & ourReadProcessInterleaved -result :: UpdateEnv -> FilePath -> Sh Text-result updateEnv resultPath = do- let expectedVersion = newVersion updateEnv- home <- get_env_text "HOME"- let logFile = workingDir (options updateEnv) </> "check-result-log.tmp"- setenv "EDITOR" "echo"- setenv "HOME" "/homeless-shelter"- let addToReport input = appendfile logFile (input <> "\n")- tempdir <- fromText . T.strip <$> cmd "mktemp" "-d"- chdir tempdir $ do- rm_f logFile- let binaryDir = resultPath </> "bin"- binExists <- test_d binaryDir+foundVersionInOutputs :: Text -> String -> IO (Maybe Text)+foundVersionInOutputs expectedVersion resultPath =+ hush+ <$> runExceptT+ ( do+ (exitCode, _) <-+ proc "grep" ["-r", T.unpack expectedVersion, resultPath]+ & ourReadProcessInterleaved+ case exitCode of+ ExitSuccess ->+ return $+ "- found "+ <> expectedVersion+ <> " with grep in "+ <> T.pack resultPath+ <> "\n"+ _ -> throwE "grep did not find version in file names"+ )++foundVersionInFileNames :: Text -> String -> IO (Maybe Text)+foundVersionInFileNames expectedVersion resultPath =+ hush+ <$> runExceptT+ ( do+ (_, contents) <-+ shell ("find " <> resultPath) & ourReadProcessInterleaved+ (contents =~ versionRegex expectedVersion) & hoistMaybe+ & noteT (T.pack "Expected version not found")+ return $+ "- found "+ <> expectedVersion+ <> " in filename of file in "+ <> T.pack resultPath+ <> "\n"+ )++treeGist :: String -> IO (Maybe Text)+treeGist resultPath =+ hush+ <$> runExceptT+ ( do+ contents <- procTree [resultPath] & ourReadProcessInterleavedBS_+ g <-+ shell gistBin & setStdin (byteStringInput contents)+ & ourReadProcessInterleaved_+ return $ "- directory tree listing: " <> g <> "\n"+ )++duGist :: String -> IO (Maybe Text)+duGist resultPath =+ hush+ <$> runExceptT+ ( do+ contents <- proc "du" [resultPath] & ourReadProcessInterleavedBS_+ g <-+ shell gistBin & setStdin (byteStringInput contents)+ & ourReadProcessInterleaved_+ return $ "- du listing: " <> g <> "\n"+ )++result :: MonadIO m => UpdateEnv -> String -> m Text+result updateEnv resultPath =+ liftIO $ do+ let expectedVersion = newVersion updateEnv+ binaryDir = resultPath <> "/bin"+ testsBuild <- checkTestsBuild (packageName updateEnv)+ binExists <- doesDirectoryExist binaryDir binaries <- if binExists- then findWhen test_f (resultPath </> "bin")+ then+ ( do+ fs <- listDirectory binaryDir+ filterM doesFileExist (map (\f -> binaryDir ++ "/" ++ f) fs)+ ) else return []- checks <- forM binaries $ \binary -> runChecks expectedVersion binary- addToReport (T.intercalate "\n" (map checkReport checks))- let passedZeroExitCode = (T.pack . show)- (foldl- (\sum c -> if zeroExitCode c then sum + 1 else sum) 0 checks :: Int)- passedVersionPresent = (T.pack . show)- (foldl- (\sum c -> if versionPresent c then sum + 1 else sum) 0 checks :: Int)+ checks' <- forM binaries $ \binary -> runChecks expectedVersion binary+ let passedZeroExitCode =+ (T.pack . show)+ ( foldl+ ( \acc c ->+ if zeroExitCode c+ then acc + 1+ else acc+ )+ 0+ checks' ::+ Int+ )+ passedVersionPresent =+ (T.pack . show)+ ( foldl+ ( \acc c ->+ if versionPresent c+ then acc + 1+ else acc+ )+ 0+ checks' ::+ Int+ ) numBinaries = (T.pack . show) (length binaries)-- addToReport ("- " <> passedZeroExitCode <> " of " <> numBinaries <> " passed binary check by having a zero exit code.")- addToReport ("- " <> passedVersionPresent <> " of " <> numBinaries <> " passed binary check by having the new version present in output.")- canFail $ cmd "grep" "-r" expectedVersion resultPath- whenM ((== 0) <$> lastExitCode) $- addToReport $- "- found " <> expectedVersion <> " with grep in " <>- toTextIgnore resultPath- whenM- (null <$>- findWhen- (\path ->- ((expectedVersion `T.isInfixOf` toTextIgnore path) &&) <$>- test_f path)- resultPath) $- addToReport $- "- found " <> expectedVersion <> " in filename of file in " <>- toTextIgnore resultPath- setenv "HOME" home- gist1 <- cmd "tree" resultPath -|- cmd "gist"- unless (T.null gist1) $ addToReport $ "- directory tree listing: " <> T.strip gist1- gist2 <- cmd "du" "-h" resultPath -|- cmd "gist"- unless (T.null gist2) $ addToReport $ "- du listing: " <> T.strip gist2- canFail $ readfile logFile+ someReports <-+ fromMaybe ""+ <$> foundVersionInOutputs expectedVersion resultPath+ <> foundVersionInFileNames expectedVersion resultPath+ <> treeGist resultPath+ <> duGist resultPath+ return $+ let testsBuildSummary = checkTestsBuildReport testsBuild+ c = T.intercalate "\n" (map checkReport checks')+ binaryCheckSummary =+ "- "+ <> passedZeroExitCode+ <> " of "+ <> numBinaries+ <> " passed binary check by having a zero exit code."+ versionPresentSummary =+ "- "+ <> passedVersionPresent+ <> " of "+ <> numBinaries+ <> " passed binary check by having the new version present in output."+ in [interpolate|+ $testsBuildSummary+ $c+ $binaryCheckSummary+ $versionPresentSummary+ $someReports+ |]
− src/Clean.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}--module Clean- ( fixSrcUrl- ) where--import Control.Applicative ((<|>), some)-import Control.Error-import Control.Monad (forM_)-import Control.Monad.Trans-import Data.Function ((&))-import Data.Maybe (isNothing)-import Data.Semigroup ((<>))-import qualified Data.Text as T-import Data.Text (Text)-import qualified File-import Prelude hiding (FilePath)-import Shelly-import qualified Text.Regex.Applicative as RE-import Text.Regex.Applicative (RE, (=~))-import Utils (UpdateEnv(..), Version, canFail, setupNixpkgs, succeded)--default (T.Text)---- | Construct regex: ${version}[^/]+\.(tar|zip)-archiveRegex :: Version -> RE Char ()-archiveRegex version =- (\_ _ _ _ -> ()) <$> RE.string (T.unpack version) <*> some (RE.psym (/= '/')) <*>- RE.sym '.' <*>- (RE.string "tar" <|> RE.string "zip")--fixSrcUrl :: UpdateEnv -> FilePath -> Text -> Text -> Sh Text-fixSrcUrl updateEnv derivationFile attrPath oldSrcUrl = do- setupNixpkgs- oldDerivationName <-- T.strip <$>- cmd "nix" "eval" "-f" "." "--raw" ("pkgs." <> attrPath <> ".name")- let newDerivationName =- T.replace- (oldVersion updateEnv)- (newVersion updateEnv)- oldDerivationName- name <-- T.strip <$>- cmd- "nix"- "eval"- "--raw"- ("(let pkgs = import ./. {}; in (builtins.parseDrvName pkgs." <> attrPath <>- ".name).name)")- whenM- (succeded $- cmd "grep" "-q" ("name = \"" <> newDerivationName <> "\"") derivationFile) $- -- Separate name and version- do- let newName = name <> "-${version}"- File.replace newDerivationName newName derivationFile- cmd "grep" "-q" ("name = \"" <> newName <> "\"") derivationFile- cmd- "sed"- "-i"- ("s|^\\([ ]*\\)\\(name = \"" <> name <>- "-${version}\";\\)|\\1\\2\n\\1version = \"" <>- newVersion updateEnv <>- "\";|")- derivationFile- cmd- "grep"- "-q"- ("version = \"" <> newVersion updateEnv <> "\";")- derivationFile- -- Obtain download URLs from repology- -- TODO: use repology-api package- downloads <-- cmd- "curl"- "-s"- ("https://repology.org/api/v1/metapackage/" <> packageName updateEnv) -|-- cmd "jq" ".[].downloads | select(values) | .[]"- let filteredDownloads =- downloads & T.lines &- filter- (\url ->- newVersion updateEnv `T.isInfixOf` url &&- isNothing (T.unpack url =~ archiveRegex (newVersion updateEnv))) &- map (T.replace "\"" "")- forResult <-- runExceptT $- runExceptRT $- forM_ filteredDownloads $ \downloadUrl -> do- let oldUrl =- T.replace- (oldVersion updateEnv)- "${version}"- (T.replace oldDerivationName "${name}" oldSrcUrl)- let newUrl =- T.replace- (newVersion updateEnv)- "${version}"- (T.replace newDerivationName "${name}" downloadUrl)- lift $ File.replace oldUrl newUrl derivationFile- lift $ cmd "grep" "-q" ("url = \"" <> newUrl <> "\";") derivationFile- whenM- (lift $- succeded $- cmd "grep" "-q" ("url = \"" <> newUrl <> "\";") derivationFile) $ do- hash <-- lift $ canFail $ cmd "nix-prefetch-url" "-A" (attrPath <> ".src")- succeedT hash- return ()- case forResult of- Right hash -> return hash- _ -> cmd "false"
+ src/Data/Hex.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++-- |+-- Module : Data.Hex+-- Copyright : (c) Taru Karttunen 2009+-- License : BSD-style+-- Maintainer : taruti@taruti.net+-- Stability : provisional+-- Portability : portable+--+-- Convert strings into hexadecimal and back.+module Data.Hex (Hex (..)) where++import Control.Monad+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L++-- | Convert strings into hexadecimal and back.+class Hex t where+ -- | Convert string into hexadecimal.+ hex :: t -> t++ -- | Convert from hexadecimal and fail on invalid input.+ unhex :: MonadFail m => t -> m t++instance Hex String where+ hex = Prelude.concatMap w+ where+ w ch =+ let s = "0123456789ABCDEF"+ x = fromEnum ch+ in [s !! div x 16, s !! mod x 16]+ unhex [] = return []+ unhex (a : b : r) = do+ x <- c a+ y <- c b+ liftM (toEnum ((x * 16) + y) :) $ unhex r+ unhex [_] = fail "Non-even length"++c :: MonadFail m => Char -> m Int+c '0' = return 0+c '1' = return 1+c '2' = return 2+c '3' = return 3+c '4' = return 4+c '5' = return 5+c '6' = return 6+c '7' = return 7+c '8' = return 8+c '9' = return 9+c 'A' = return 10+c 'B' = return 11+c 'C' = return 12+c 'D' = return 13+c 'E' = return 14+c 'F' = return 15+c 'a' = return 10+c 'b' = return 11+c 'c' = return 12+c 'd' = return 13+c 'e' = return 14+c 'f' = return 15+c _ = fail "Invalid hex digit!"++instance Hex B.ByteString where+ hex = B.pack . hex . B.unpack+ unhex x = liftM B.pack $ unhex $ B.unpack x++instance Hex L.ByteString where+ hex = L.pack . hex . L.unpack+ unhex x = liftM L.pack $ unhex $ L.unpack x
src/DeleteMerged.hs view
@@ -1,52 +1,29 @@-{-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-} module DeleteMerged- ( deleteMerged- , deleteDone- ) where+ ( deleteDone,+ )+where -import Control.Monad (forM_)-import Data.Function ((&))-import Data.Maybe (mapMaybe)-import Data.Semigroup ((<>))-import qualified Data.Text as T import qualified Data.Text.IO as T-import qualified Git import qualified GH-import Shelly-import Utils (Options, ourShell, setupNixpkgs)-import qualified Data.Vector as V--default (T.Text)---- | Delete the already merged branches both from local and remote repository-deleteMerged :: Options -> IO ()-deleteMerged o =- ourShell o $ do- setupNixpkgs- Git.fetch- Git.cleanAndResetToMaster- mergedRemoteBranches <- T.lines <$> cmd "git" "branch" "-ra" "--merged"- let mergedRemoteAutoUpdateBranches =- mergedRemoteBranches & filter ("origin/auto-update/" `T.isInfixOf`) &- mapMaybe (T.stripPrefix "remotes/origin/" . T.strip)- forM_ mergedRemoteAutoUpdateBranches $ \branch ->- cmd "git" "push" "origin" (":" <> branch)- mergedBranches <- T.lines <$> cmd "git" "branch" "-a" "--merged"- let mergedAutoUpdateBranches =- mergedBranches & filter ("auto-update/" `T.isInfixOf`) & map T.strip- forM_ mergedAutoUpdateBranches $ \branch -> cmd "git" "branch" "-d" branch+import qualified Git+import GitHub.Data (Name, Owner)+import OurPrelude -deleteDone :: Options -> IO ()-deleteDone o =- ourShell o $ do- setupNixpkgs- Git.fetch- Git.cleanAndResetToMaster- result <- liftIO $ GH.closedAutoUpdateRefs o- case result of- Left error -> liftIO $ T.putStrLn error- Right refs ->- V.sequence_ (fmap (\r -> Git.deleteBranch ("auto-update/" <> r)) refs)+deleteDone :: Bool -> Text -> Name Owner -> IO ()+deleteDone delete githubToken ghUser = do+ result <-+ runExceptT $ do+ Git.fetch+ Git.cleanAndResetTo "master"+ refs <- ExceptT $ GH.closedAutoUpdateRefs (GH.authFromToken githubToken) ghUser+ let branches = fmap (\r -> ("auto-update/" <> r)) refs+ if delete+ then liftIO $ Git.deleteBranchesEverywhere branches+ else liftIO $ do+ T.putStrLn $ "Would delete these branches for " <> tshow ghUser <> ":"+ mapM_ (T.putStrLn . tshow) branches+ case result of+ Left e -> T.putStrLn e+ _ -> return ()
src/File.hs view
@@ -1,19 +1,59 @@-module File- ( replace- ) where+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} -import Data.Text (Text)+module File where+ import qualified Data.Text as T-import Data.Text.IO as T-import qualified Shelly-import Shelly (liftIO, toTextIgnore, Sh)+import Data.Text.IO as T+import OurPrelude+import Polysemy.Input+import Polysemy.Output -replaceIO :: Text -> Text -> FilePath -> IO ()-replaceIO find r file = do- contents <- T.readFile file- T.writeFile file (T.replace find r contents)+data File m a where+ Read :: FilePath -> File m Text+ Write :: FilePath -> Text -> File m () -replace :: Text -> Text -> Shelly.FilePath -> Sh ()-replace find r file = liftIO $ replaceIO find r f- where- f = (T.unpack . toTextIgnore) file+makeSem ''File++runIO ::+ Member (Embed IO) r =>+ Sem (File ': r) a ->+ Sem r a+runIO =+ interpret $ \case+ Read file -> embed $ T.readFile file+ Write file contents -> embed $ T.writeFile file contents++runPure ::+ [Text] ->+ Sem (File ': r) a ->+ Sem r ([Text], a)+runPure contentList =+ runOutputMonoid pure+ . runInputList contentList+ . reinterpret2 \case+ Read _file -> maybe "" id <$> input+ Write _file contents -> output contents++replace ::+ Member File r =>+ Text ->+ Text ->+ FilePath ->+ Sem r Bool+replace find replacement file = do+ contents <- File.read file+ let newContents = T.replace find replacement contents+ when (contents /= newContents) $ do+ File.write file newContents+ return $ contents /= newContents++replaceIO :: MonadIO m => Text -> Text -> FilePath -> m Bool+replaceIO find replacement file =+ liftIO $+ runFinal $+ embedToFinal $+ runIO $+ (replace find replacement file)
src/GH.hs view
@@ -1,109 +1,209 @@ {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module GH- ( GH.releaseUrl- , compareUrl- , pr- , closedAutoUpdateRefs- ) where+ ( releaseUrl,+ GH.untagName,+ authFromToken,+ checkExistingUpdatePR,+ closedAutoUpdateRefs,+ compareUrl,+ latestVersion,+ openAutoUpdatePR,+ openPullRequests,+ pr,+ )+where -import Control.Category ((>>>))-import Control.Error-import Data.Bifunctor (bimap, first, second)-import Data.Function ((&))-import Data.Maybe (fromJust)-import Data.Semigroup ((<>))+import Control.Applicative (some) import qualified Data.Text as T-import Data.Text (Text) import qualified Data.Text.Encoding as T import qualified Data.Vector as V-import Data.Vector (Vector)-import GitHub-import GitHub.Data.Name (Name(..), untagName)-import GitHub.Endpoints.GitData.References (references')-import GitHub.Endpoints.Repos.Releases (releaseByTagName)-import Shelly hiding (tag)-import Utils+import qualified GitHub as GH+import GitHub.Data.Name (Name (..))+import OurPrelude+import Text.Regex.Applicative.Text ((=~))+import qualified Text.Regex.Applicative.Text as RE+import Utils (UpdateEnv (..), Version)+import qualified Utils as U -gReleaseUrl :: URLParts -> IO (Either Text Text)-gReleaseUrl (URLParts owner repo tag) =- bimap (T.pack . show) (getUrl . releaseHtmlUrl) <$>- releaseByTagName owner repo tag+default (T.Text) -releaseUrl :: Text -> IO (Either Text Text)-releaseUrl url =- runExceptT $ do- urlParts <- ExceptT $ parseURL url- ExceptT $ gReleaseUrl urlParts+gReleaseUrl :: MonadIO m => GH.Auth -> URLParts -> ExceptT Text m Text+gReleaseUrl auth (URLParts o r t) =+ ExceptT $+ bimap (T.pack . show) (GH.getUrl . GH.releaseHtmlUrl)+ <$> liftIO (GH.github auth (GH.releaseByTagNameR o r t)) -pr :: Text -> Sh ()-pr = cmd "hub" "pull-request" "-m"+releaseUrl :: MonadIO m => UpdateEnv -> Text -> ExceptT Text m Text+releaseUrl env url = do+ urlParts <- parseURL url+ gReleaseUrl (authFrom env) urlParts +pr :: MonadIO m => UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text m Text+pr env title body prHead base = do+ ExceptT $+ bimap (T.pack . show) (GH.getUrl . GH.pullRequestUrl)+ <$> ( liftIO $+ ( GH.github+ (authFrom env)+ ( GH.createPullRequestR+ (N "nixos")+ (N "nixpkgs")+ (GH.CreatePullRequest title body prHead base)+ )+ )+ )+ data URLParts = URLParts- { owner :: Name Owner- , repo :: Name Repo- , tag :: Text+ { owner :: GH.Name GH.Owner,+ repo :: GH.Name GH.Repo,+ tag :: Text }+ deriving (Show) -parseURL :: Text -> IO (Either Text URLParts)+-- | Parse owner-repo-branch triplet out of URL+-- We accept URLs pointing to uploaded release assets+-- that are usually obtained with fetchurl, as well+-- as the generated archives that fetchFromGitHub downloads.+--+-- Examples:+--+-- >>> parseURLMaybe "https://github.com/blueman-project/blueman/releases/download/2.0.7/blueman-2.0.7.tar.xz"+-- Just (URLParts {owner = N "blueman-project", repo = N "blueman", tag = "2.0.7"})+--+-- >>> parseURLMaybe "https://github.com/arvidn/libtorrent/archive/libtorrent_1_1_11.tar.gz"+-- Just (URLParts {owner = N "arvidn", repo = N "libtorrent", tag = "libtorrent_1_1_11"})+--+-- >>> parseURLMaybe "https://gitlab.com/inkscape/lib2geom/-/archive/1.0/lib2geom-1.0.tar.gz"+-- Nothing+parseURLMaybe :: Text -> Maybe URLParts+parseURLMaybe url =+ let domain = RE.string "https://github.com/"+ slash = RE.sym '/'+ pathSegment = T.pack <$> some (RE.psym (/= '/'))+ extension = RE.string ".zip" <|> RE.string ".tar.gz"+ toParts n o = URLParts (N n) (N o)+ regex =+ ( toParts <$> (domain *> pathSegment) <* slash <*> pathSegment+ <*> (RE.string "/releases/download/" *> pathSegment)+ <* slash+ <* pathSegment+ )+ <|> ( toParts <$> (domain *> pathSegment) <* slash <*> pathSegment+ <*> (RE.string "/archive/" *> pathSegment)+ <* extension+ )+ in url =~ regex++parseURL :: MonadIO m => Text -> ExceptT Text m URLParts parseURL url =- runExceptT $ do- tryAssert- ("GitHub: " <> url <> " is not a GitHub URL.")- ("https://github.com/" `T.isPrefixOf` url)- let parts = T.splitOn "/" url- owner <- N <$> tryAt ("GitHub: owner part missing from " <> url) parts 3- repo <- N <$> tryAt ("GitHub: repo part missing from " <> url) parts 4- tagPart <- tryAt ("GitHub: tag part missing from " <> url) parts 6- tag <-- tryJust- ("GitHub: tag part missing .tar.gz suffix " <> url)- (T.stripSuffix ".tar.gz" tagPart)- return $ URLParts owner repo tag+ tryJust ("GitHub: " <> url <> " is not a GitHub URL.") (parseURLMaybe url) -compareUrl :: Text -> Text -> IO (Either Text Text)-compareUrl urlOld urlNew =- runExceptT $ do- oldParts <- ExceptT $ parseURL urlOld- newParts <- ExceptT $ parseURL urlNew- return $- "https://github.com/" <> untagName (owner newParts) <> "/" <>- untagName (repo newParts) <>- "/compare/" <>- tag oldParts <>- "..." <>- tag newParts+compareUrl :: MonadIO m => Text -> Text -> ExceptT Text m Text+compareUrl urlOld urlNew = do+ oldParts <- parseURL urlOld+ newParts <- parseURL urlNew+ return $+ "https://github.com/"+ <> GH.untagName (owner newParts)+ <> "/"+ <> GH.untagName (repo newParts)+ <> "/compare/"+ <> tag oldParts+ <> "..."+ <> tag newParts ---deleteDoneBranches :: IO ()---deleteDoneBranches = do-autoUpdateRefs :: Options -> IO (Either Text (Vector Text))-autoUpdateRefs o =- references' (Just (OAuth (T.encodeUtf8 (githubToken o)))) "r-ryantm" "nixpkgs" &- fmap- (first (T.pack . show) >>>- second (fmap gitReferenceRef >>> V.mapMaybe (T.stripPrefix prefix)))+autoUpdateRefs :: GH.Auth -> GH.Name GH.Owner -> IO (Either Text (Vector Text))+autoUpdateRefs auth ghUser =+ GH.github auth (GH.referencesR ghUser "nixpkgs" GH.FetchAll)+ & ((fmap . fmapL) tshow)+ & ((fmap . fmapR) (fmap (GH.gitReferenceRef >>> GH.untagName) >>> V.mapMaybe (T.stripPrefix prefix))) where prefix = "refs/heads/auto-update/" -openPRWithAutoUpdateRef :: Options -> Text -> IO (Either Text Bool)-openPRWithAutoUpdateRef o ref =- (executeRequest (OAuth (T.encodeUtf8 (githubToken o))) $- pullRequestsForR- "nixos"- "nixpkgs"- (optionsHead ("r-ryantm:auto-update/" <> ref) <> stateOpen)- FetchAll) &- fmap (first (T.pack . show) >>> second (\v -> not (V.null v)))+openPRWithAutoUpdateRefFrom :: GH.Auth -> GH.Name GH.Owner -> Text -> IO (Either Text Bool)+openPRWithAutoUpdateRefFrom auth ghUser ref =+ GH.executeRequest+ auth+ ( GH.pullRequestsForR+ "nixos"+ "nixpkgs"+ (GH.optionsHead (GH.untagName ghUser <> ":" <> U.branchPrefix <> ref) <> GH.stateOpen)+ GH.FetchAll+ )+ & fmap (first (T.pack . show) >>> second (not . V.null)) -refShouldBeDeleted :: Options -> Text -> IO Bool-refShouldBeDeleted o ref =- not <$> either (const True) id <$> openPRWithAutoUpdateRef o ref+refShouldBeDeleted :: GH.Auth -> GH.Name GH.Owner -> Text -> IO Bool+refShouldBeDeleted auth ghUser ref =+ not . either (const True) id+ <$> openPRWithAutoUpdateRefFrom auth ghUser ref -closedAutoUpdateRefs :: Options -> IO (Either Text (Vector Text))-closedAutoUpdateRefs o =+closedAutoUpdateRefs :: GH.Auth -> GH.Name GH.Owner -> IO (Either Text (Vector Text))+closedAutoUpdateRefs auth ghUser = runExceptT $ do- aur :: Vector Text <- ExceptT $ autoUpdateRefs o- ExceptT (Right <$> V.filterM (refShouldBeDeleted o) aur)+ aur :: Vector Text <- ExceptT $ GH.autoUpdateRefs auth ghUser+ ExceptT (Right <$> V.filterM (refShouldBeDeleted auth ghUser) aur)++-- This is too slow+openPullRequests :: Text -> IO (Either Text (Vector GH.SimplePullRequest))+openPullRequests githubToken =+ GH.executeRequest+ (GH.OAuth (T.encodeUtf8 githubToken))+ (GH.pullRequestsForR "nixos" "nixpkgs" GH.stateOpen GH.FetchAll)+ & fmap (first (T.pack . show))++openAutoUpdatePR :: UpdateEnv -> Vector GH.SimplePullRequest -> Bool+openAutoUpdatePR updateEnv oprs = oprs & (V.find isThisPkg >>> isJust)+ where+ isThisPkg simplePullRequest =+ let title = GH.simplePullRequestTitle simplePullRequest+ titleHasName = (packageName updateEnv <> ":") `T.isPrefixOf` title+ titleHasNewVersion = newVersion updateEnv `T.isSuffixOf` title+ in titleHasName && titleHasNewVersion++authFromToken :: Text -> GH.Auth+authFromToken = GH.OAuth . T.encodeUtf8++authFrom :: UpdateEnv -> GH.Auth+authFrom = authFromToken . U.githubToken . options++checkExistingUpdatePR :: MonadIO m => UpdateEnv -> Text -> ExceptT Text m ()+checkExistingUpdatePR env attrPath = do+ searchResult <-+ ExceptT $+ liftIO $+ GH.github (authFrom env) (GH.searchIssuesR search)+ & fmap (first (T.pack . show))+ if T.length (openPRReport searchResult) == 0+ then return ()+ else+ throwE+ ( "There might already be an open PR for this update:\n"+ <> openPRReport searchResult+ )+ where+ title = U.prTitle env attrPath+ search = [interpolate|repo:nixos/nixpkgs $title |]+ openPRReport searchResult =+ GH.searchResultResults searchResult+ & V.filter (GH.issueClosedAt >>> isNothing)+ & V.filter (GH.issuePullRequest >>> isJust)+ & fmap report+ & V.toList+ & T.unlines+ report i = "- " <> GH.issueTitle i <> "\n " <> tshow (GH.issueUrl i)++latestVersion :: MonadIO m => UpdateEnv -> Text -> ExceptT Text m Version+latestVersion env url = do+ urlParts <- parseURL url+ r <-+ fmapLT tshow $+ ExceptT $+ liftIO $+ GH.executeRequest (authFrom env) $+ GH.latestReleaseR (owner urlParts) (repo urlParts)+ return $ T.dropWhile (\c -> c == 'v' || c == 'V') (GH.releaseTagName r)
src/Git.hs view
@@ -1,97 +1,235 @@-{-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE TemplateHaskell #-} module Git- ( cleanAndResetToMaster- , cleanAndResetToStaging- , cleanup- , fetchIfStale- , fetch- , push- , checkoutAtMergeBase- , autoUpdateBranchExists- , commit- , headHash- , deleteBranch- ) where+ ( checkAutoUpdateBranchDoesntExist,+ checkoutAtMergeBase,+ cleanAndResetTo,+ cleanup,+ commit,+ deleteBranchesEverywhere,+ diff,+ fetch,+ fetchIfStale,+ headHash,+ push,+ nixpkgsDir,+ setupNixpkgs,+ Git.show,+ )+where -import Data.Semigroup ((<>))+import Control.Concurrent+import Control.Exception+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Maybe (fromJust) import qualified Data.Text as T-import Data.Text (Text)-import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)-import Shelly-import System.Directory (getModificationTime, getHomeDirectory)-import Utils (Options(..), UpdateEnv(..), branchName, canFail)+import qualified Data.Text.IO as T+import Data.Time.Clock (addUTCTime, getCurrentTime)+import qualified Data.Vector as V+import Language.Haskell.TH.Env (envQ)+import OurPrelude hiding (throw)+import System.Directory (doesDirectoryExist, doesFileExist, getModificationTime, getCurrentDirectory, setCurrentDirectory)+import System.Environment (getEnv)+import System.Environment.XDG.BaseDir (getUserCacheDir)+import System.Exit+import System.IO.Error (tryIOError)+import System.Posix.Env (setEnv)+import qualified System.Process.Typed+import Utils (Options (..), UpdateEnv (..), branchName, branchPrefix) -default (T.Text)+bin :: String+bin = fromJust ($$(envQ "GIT") :: Maybe String) <> "/bin/git" -clean :: Sh ()-clean = cmd "git" "clean" "-fdx"+procGit :: [String] -> ProcessConfig () () ()+procGit = proc bin -cleanAndResetTo :: Text -> Text -> Sh ()-cleanAndResetTo branch target = do- cmd "git" "reset" "--hard"- clean- cmd "git" "checkout" "-B" branch target- cmd "git" "reset" "--hard" target- clean+hubBin :: String+hubBin = fromJust ($$(envQ "HUB") :: Maybe String) <> "/bin/hub" -cleanAndResetToMaster :: Sh ()-cleanAndResetToMaster = cleanAndResetTo "master" "upstream/master"+procHub :: [String] -> ProcessConfig () () ()+procHub = proc hubBin -cleanAndResetToStaging :: Sh ()-cleanAndResetToStaging = cleanAndResetTo "staging" "upstream/staging"+clean :: ProcessConfig () () ()+clean = silently $ procGit ["clean", "-fdx"] -cleanup :: Text -> Sh ()-cleanup branchName = do- cleanAndResetToMaster- canFail $ cmd "git" "branch" "-D" branchName+checkout :: Text -> Text -> ProcessConfig () () ()+checkout branch target =+ silently $ procGit ["checkout", "-B", T.unpack branch, T.unpack target] -staleFetchHead :: IO Bool-staleFetchHead = do- home <- getHomeDirectory- let fetchHead = home <> "/.cache/nixpkgs/.git/FETCH_HEAD"- oneHourAgo <- addUTCTime (fromInteger $ -60 * 60) <$> getCurrentTime- fetchedLast <- getModificationTime fetchHead- return (fetchedLast < oneHourAgo)+reset :: Text -> ProcessConfig () () ()+reset target = silently $ procGit ["reset", "--hard", T.unpack target] -fetchIfStale :: Sh ()-fetchIfStale =- whenM- (liftIO staleFetchHead)- fetch+delete1 :: Text -> ProcessConfig () () ()+delete1 branch = delete [branch] -fetch :: Sh ()-fetch = canFail $ cmd "git" "fetch" "-q" "--prune" "--multiple" "upstream" "origin"+delete :: [Text] -> ProcessConfig () () ()+delete branches = silently $ procGit (["branch", "-D"] ++ fmap T.unpack branches) -push :: UpdateEnv -> Sh ()+deleteOrigin :: [Text] -> ProcessConfig () () ()+deleteOrigin branches =+ silently $ procGit (["push", "origin", "--delete"] ++ fmap T.unpack branches)++cleanAndResetTo :: MonadIO m => Text -> ExceptT Text m ()+cleanAndResetTo branch =+ let target = "upstream/" <> branch+ in do+ runProcessNoIndexIssue_ $ silently $ procGit ["reset", "--hard"]+ runProcessNoIndexIssue_ clean+ runProcessNoIndexIssue_ $ checkout branch target+ runProcessNoIndexIssue_ $ reset target+ runProcessNoIndexIssue_ clean++show :: MonadIO m => Text -> Text -> ExceptT Text m Text+show branch file =+ readProcessInterleavedNoIndexIssue_ $ silently $ procGit ["show", T.unpack ("remotes/upstream/" <> branch <> ":" <> file)]++cleanup :: MonadIO m => Text -> ExceptT Text m ()+cleanup bName = do+ liftIO $ T.putStrLn ("Cleaning up " <> bName)+ cleanAndResetTo "master"+ runProcessNoIndexIssue_ (delete1 bName)+ <|> liftIO (T.putStrLn ("Couldn't delete " <> bName))++diff :: MonadIO m => Text -> ExceptT Text m Text+diff branch = readProcessInterleavedNoIndexIssue_ $ procGit ["diff", T.unpack branch]++staleFetchHead :: MonadIO m => m Bool+staleFetchHead =+ liftIO $ do+ nixpkgsGit <- getUserCacheDir "nixpkgs"+ let fetchHead = nixpkgsGit <> "/.git/FETCH_HEAD"+ oneHourAgo <- addUTCTime (fromInteger $ -60 * 60) <$> getCurrentTime+ e <- tryIOError $ getModificationTime fetchHead+ if isLeft e+ then do+ return True+ else do+ fetchedLast <- getModificationTime fetchHead+ return (fetchedLast < oneHourAgo)++fetchIfStale :: MonadIO m => ExceptT Text m ()+fetchIfStale = whenM staleFetchHead fetch++fetch :: MonadIO m => ExceptT Text m ()+fetch =+ runProcessNoIndexIssue_ $+ silently $ procGit ["fetch", "-q", "--prune", "--multiple", "upstream", "origin"]++push :: MonadIO m => UpdateEnv -> ExceptT Text m () push updateEnv =- run_- "git"- (["push", "--force", "--set-upstream", "origin", branchName updateEnv] ++- ["--dry-run" | dryRun (options updateEnv)])+ runProcessNoIndexIssue_+ ( procGit+ ( [ "push",+ "--force",+ "--set-upstream",+ "origin",+ T.unpack (branchName updateEnv)+ ]+ ++ ["--dry-run" | not (doPR (options updateEnv))]+ )+ ) -checkoutAtMergeBase :: Text -> Sh ()-checkoutAtMergeBase branchName = do+nixpkgsDir :: IO FilePath+nixpkgsDir = do+ inNixpkgs <- inNixpkgsRepo+ if inNixpkgs+ then getCurrentDirectory+ else getUserCacheDir "nixpkgs"++-- Setup a NixPkgs clone in $XDG_CACHE_DIR/nixpkgs+-- Since we are going to have to fetch, git reset, clean, and commit, we setup a+-- cache dir to avoid destroying any uncommitted work the user may have in PWD.+setupNixpkgs :: Text -> IO ()+setupNixpkgs githubt = do+ fp <- nixpkgsDir+ exists <- doesDirectoryExist fp+ unless exists $ do+ path <- getEnv "PATH"+ procHub ["clone", "nixpkgs", fp]+ & System.Process.Typed.setEnv -- requires that user has forked nixpkgs+ [ ("PATH" :: String, path),+ ("GITHUB_TOKEN" :: String, githubt & T.unpack)+ ]+ & runProcess_+ setCurrentDirectory fp+ shell (bin <> "remote add upstream https://github.com/NixOS/nixpkgs")+ & runProcess_+ inNixpkgs <- inNixpkgsRepo+ unless inNixpkgs do+ setCurrentDirectory fp+ _ <- runExceptT fetchIfStale+ _ <- runExceptT $ cleanAndResetTo "master"+ return ()+ System.Posix.Env.setEnv "NIX_PATH" ("nixpkgs=" <> fp) True++checkoutAtMergeBase :: MonadIO m => Text -> ExceptT Text m Text+checkoutAtMergeBase bName = do base <-- T.strip <$> cmd "git" "merge-base" "upstream/master" "upstream/staging"- cmd "git" "checkout" "-B" branchName base+ readProcessInterleavedNoIndexIssue_+ (procGit ["merge-base", "upstream/master", "upstream/staging"])+ & fmapRT T.strip+ runProcessNoIndexIssue_ (checkout bName base)+ return base -autoUpdateBranchExists :: Text -> Sh Bool-autoUpdateBranchExists packageName = do- remotes <-- map T.strip . T.lines <$> (silently $ cmd "git" "branch" "--remote")- return $ ("origin/auto-update/" <> packageName) `elem` remotes+checkAutoUpdateBranchDoesntExist :: MonadIO m => Text -> ExceptT Text m ()+checkAutoUpdateBranchDoesntExist pName = do+ remoteBranches <-+ readProcessInterleavedNoIndexIssue_ (procGit ["branch", "--remote"])+ & fmapRT (T.lines >>> fmap T.strip)+ when+ (("origin/" <> branchPrefix <> pName) `elem` remoteBranches)+ (throwE "Update branch already on origin.") -commit :: Text -> Sh ()-commit = cmd "git" "commit" "-am"+inNixpkgsRepo :: IO Bool+inNixpkgsRepo = do+ currentDir <- getCurrentDirectory+ doesFileExist (currentDir <> "/nixos/release.nix") -headHash :: Sh Text-headHash = cmd "git" "rev-parse" "HEAD"+commit :: MonadIO m => Text -> ExceptT Text m ()+commit ref =+ runProcessNoIndexIssue_ (procGit ["commit", "-am", T.unpack ref]) -deleteBranch :: Text -> Sh ()-deleteBranch branchName = do- canFail $ do- cmd "git" "branch" "-D" branchName- cmd "git" "push" "origin" (":" <> branchName)+headHash :: MonadIO m => ExceptT Text m Text+headHash = T.strip <$> readProcessInterleavedNoIndexIssue_ (procGit ["rev-parse", "HEAD"])++deleteBranchesEverywhere :: Vector Text -> IO ()+deleteBranchesEverywhere branches = do+ let branchList = V.toList $ branches+ result <- runExceptT $ runProcessNoIndexIssue_ (delete branchList)+ case result of+ Left error1 -> T.putStrLn $ tshow error1+ Right success1 -> T.putStrLn $ tshow success1+ result2 <- runExceptT $ runProcessNoIndexIssue_ (deleteOrigin branchList)+ case result2 of+ Left error2 -> T.putStrLn $ tshow error2+ Right success2 -> T.putStrLn $ tshow success2++runProcessNoIndexIssue_ ::+ MonadIO m => ProcessConfig () () () -> ExceptT Text m ()+runProcessNoIndexIssue_ config = tryIOTextET go+ where+ go = do+ (code, out, e) <- readProcess config+ case code of+ ExitFailure 128+ | "index.lock" `BS.isInfixOf` BSL.toStrict e -> do+ threadDelay 100000+ go+ ExitSuccess -> return ()+ ExitFailure _ -> throw $ ExitCodeException code config out e++readProcessInterleavedNoIndexIssue_ ::+ MonadIO m => ProcessConfig () () () -> ExceptT Text m Text+readProcessInterleavedNoIndexIssue_ config = tryIOTextET go+ where+ go = do+ (code, out) <- readProcessInterleaved config+ case code of+ ExitFailure 128+ | "index.lock" `BS.isInfixOf` BSL.toStrict out -> do+ threadDelay 100000+ go+ ExitSuccess -> return $ bytestringToText out+ ExitFailure _ -> throw $ ExitCodeException code config out out
− src/Main.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}--import Control.Applicative ((<**>), (<|>))-import Control.Exception-import Data.Maybe (isJust)-import Data.Semigroup ((<>))-import qualified Data.Text as T-import Data.Text (Text)-import qualified Data.Text.IO as T-import DeleteMerged (deleteDone)-import qualified Options.Applicative as Opt-import System.Directory (getHomeDirectory)-import System.Posix.Env (getEnv)-import Update (updateAll)-import Utils (Options(..))--default (T.Text)--data Mode- = Update- | DeleteDone--modeParser :: Opt.Parser Mode-modeParser =- Opt.flag'- Update- (Opt.long "update" <> Opt.help "Update packages (default mode)") <|>- Opt.flag'- DeleteDone- (Opt.long "delete-done" <>- Opt.help "Delete branches from PRs that were merged or closed")--programInfo :: Opt.ParserInfo Mode-programInfo =- Opt.info- (modeParser <**> Opt.helper)- (Opt.fullDesc <> Opt.progDesc "Update packages in nixpkgs repository" <>- Opt.header "nixpkgs-update")--makeOptions :: IO Options-makeOptions = do- dryRun <- isJust <$> getEnv "DRY_RUN"- homeDir <- T.pack <$> getHomeDirectory- githubToken <- T.strip <$> T.readFile "github_token.txt"- return $ Options dryRun (homeDir <> "/.nixpkgs-update") githubToken--main :: IO ()-main = do- mode <- Opt.execParser programInfo- options <- makeOptions- case mode of- DeleteDone -> deleteDone options- Update -> updateAll options
+ src/NVD.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module NVD+ ( withVulnDB,+ getCVEs,+ Connection,+ ProductID,+ Version,+ CVE,+ CVEID,+ UTCTime,+ )+where++import CVE+ ( CPEMatch (..),+ CPEMatchRow (..),+ CVE (..),+ CVEID,+ cpeMatches,+ parseFeed,+ )+import Codec.Compression.GZip (decompress)+import Control.Exception (SomeException, try)+import Crypto.Hash.SHA256 (hashlazy)+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.Hex (hex, unhex)+import Data.List (group)+import qualified Data.Text as T+import Data.Time.Calendar (toGregorian)+import Data.Time.Clock+ ( UTCTime,+ diffUTCTime,+ getCurrentTime,+ nominalDay,+ utctDay,+ )+import Data.Time.ISO8601 (parseISO8601)+import Database.SQLite.Simple+ ( Connection,+ Only (..),+ Query (..),+ execute,+ executeMany,+ execute_,+ query,+ withConnection,+ withTransaction,+ )+import qualified NVDRules+import Network.HTTP.Conduit (simpleHttp)+import OurPrelude+import System.Directory+ ( XdgDirectory (..),+ createDirectoryIfMissing,+ getXdgDirectory,+ removeFile,+ )+import System.FilePath ((</>))+import Utils (ProductID, Version)+import Version (matchVersion)++-- | Either @recent@, @modified@, or any year since @2002@.+type FeedID = String++type Extension = String++type Timestamp = UTCTime++type Checksum = BSL.ByteString++type DBVersion = Int++data Meta+ = Meta Timestamp Checksum++-- | Database version the software expects. If the software version is+-- higher than the database version or the database has not been updated in more+-- than 7.5 days, the database will be deleted and rebuilt from scratch. Bump+-- this when the database layout changes or the build-time data filtering+-- changes.+softwareVersion :: DBVersion+softwareVersion = 2++getDBPath :: IO FilePath+getDBPath = do+ cacheDir <- getXdgDirectory XdgCache "nixpkgs-update"+ createDirectoryIfMissing True cacheDir+ pure $ cacheDir </> "nvd.sqlite3"++withDB :: (Connection -> IO a) -> IO a+withDB action = do+ dbPath <- getDBPath+ withConnection dbPath action++markUpdated :: Connection -> IO ()+markUpdated conn = do+ now <- getCurrentTime+ execute conn "UPDATE meta SET last_update = ?" [now]++-- | Rebuild the entire database, redownloading all data.+rebuildDB :: IO ()+rebuildDB = do+ dbPath <- getDBPath+ removeFile dbPath+ withConnection dbPath $ \conn -> do+ execute_ conn "CREATE TABLE meta (db_version int, last_update text)"+ execute+ conn+ "INSERT INTO meta VALUES (?, ?)"+ (softwareVersion, "1970-01-01 00:00:00" :: Text)+ execute_ conn $+ Query $+ T.unlines+ [ "CREATE TABLE cves (",+ " cve_id text PRIMARY KEY,",+ " description text,",+ " published text,",+ " modified text)"+ ]+ execute_ conn $+ Query $+ T.unlines+ [ "CREATE TABLE cpe_matches (",+ " cve_id text REFERENCES cve,",+ " part text,",+ " vendor text,",+ " product text,",+ " version text,",+ " \"update\" text,",+ " edition text,",+ " language text,",+ " software_edition text,",+ " target_software text,",+ " target_hardware text,",+ " other text,",+ " matcher text)"+ ]+ execute_ conn "CREATE INDEX matchers_by_cve ON cpe_matches(cve_id)"+ execute_ conn "CREATE INDEX matchers_by_product ON cpe_matches(product)"+ execute_ conn "CREATE INDEX matchers_by_vendor ON cpe_matches(vendor)"+ execute_+ conn+ "CREATE INDEX matchers_by_target_software ON cpe_matches(target_software)"+ years <- allYears+ forM_ years $ updateFeed conn+ markUpdated conn++feedURL :: FeedID -> Extension -> String+feedURL feed ext =+ "https://nvd.nist.gov/feeds/json/cve/1.1/nvdcve-1.1-" <> feed <> ext++throwString :: String -> IO a+throwString = ioError . userError++throwText :: Text -> IO a+throwText = throwString . T.unpack++allYears :: IO [FeedID]+allYears = do+ now <- getCurrentTime+ let (year, _, _) = toGregorian $ utctDay now+ return $ map show [2002 .. year]++parseMeta :: BSL.ByteString -> Either T.Text Meta+parseMeta raw = do+ let splitLine = second BSL.tail . BSL.break (== ':') . BSL.takeWhile (/= '\r')+ let fields = map splitLine $ BSL.lines raw+ lastModifiedDate <-+ note "no lastModifiedDate in meta" $ lookup "lastModifiedDate" fields+ sha256 <- note "no sha256 in meta" $ lookup "sha256" fields+ timestamp <-+ note "invalid lastModifiedDate in meta" $+ parseISO8601 $+ BSL.unpack lastModifiedDate+ checksum <- note "invalid sha256 in meta" $ unhex sha256+ return $ Meta timestamp checksum++getMeta :: FeedID -> IO Meta+getMeta feed = do+ raw <- simpleHttp $ feedURL feed ".meta"+ either throwText pure $ parseMeta raw++getCVE :: Connection -> CVEID -> IO CVE+getCVE conn cveID_ = do+ cves <-+ query+ conn+ ( Query $+ T.unlines+ [ "SELECT cve_id, description, published, modified",+ "FROM cves",+ "WHERE cve_id = ?"+ ]+ )+ (Only cveID_)+ case cves of+ [cve] -> pure cve+ [] -> fail $ "no cve with id " <> (T.unpack cveID_)+ _ -> fail $ "multiple cves with id " <> (T.unpack cveID_)++getCVEs :: Connection -> ProductID -> Version -> IO [CVE]+getCVEs conn productID version = do+ matches :: [CPEMatchRow] <-+ query+ conn+ ( Query $+ T.unlines+ [ "SELECT",+ " cve_id,",+ " part,",+ " vendor,",+ " product,",+ " version,",+ " \"update\",",+ " edition,",+ " language,",+ " software_edition,",+ " target_software,",+ " target_hardware,",+ " other,",+ " matcher",+ "FROM cpe_matches",+ "WHERE vendor = ? or product = ? or edition = ? or software_edition = ? or target_software = ?",+ "ORDER BY cve_id"+ ]+ )+ (productID, productID, productID, productID, productID)+ let cveIDs =+ map head $+ group $+ flip mapMaybe matches $+ \(CPEMatchRow cve cpeMatch) ->+ if matchVersion (cpeMatchVersionMatcher cpeMatch) version+ then+ if NVDRules.filter cve cpeMatch productID version+ then Just (cveID cve)+ else Nothing+ else Nothing+ forM cveIDs $ getCVE conn++putCVEs :: Connection -> [CVE] -> IO ()+putCVEs conn cves = do+ withTransaction conn $ do+ executeMany+ conn+ "DELETE FROM cves WHERE cve_id = ?"+ (map (Only . cveID) cves)+ executeMany+ conn+ ( Query $+ T.unlines+ [ "INSERT INTO cves(cve_id, description, published, modified)",+ "VALUES (?, ?, ?, ?)"+ ]+ )+ cves+ executeMany+ conn+ "DELETE FROM cpe_matches WHERE cve_id = ?"+ (map (Only . cveID) cves)+ executeMany+ conn+ ( Query $+ T.unlines+ [ "INSERT INTO cpe_matches(",+ " cve_id,",+ " part,",+ " vendor,",+ " product,",+ " version,",+ " \"update\",",+ " edition,",+ " language,",+ " software_edition,",+ " target_software,",+ " target_hardware,",+ " other,",+ " matcher)",+ "VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"+ ]+ )+ (cpeMatches cves)++getDBMeta :: Connection -> IO (DBVersion, UTCTime)+getDBMeta conn = do+ rows <- query conn "SELECT db_version, last_update FROM meta" ()+ case rows of+ [meta] -> pure meta+ _ -> fail "failed to get meta information"++needsRebuild :: IO Bool+needsRebuild = do+ dbMeta <- try $ withDB getDBMeta+ currentTime <- getCurrentTime+ case dbMeta of+ Left (e :: SomeException) -> do+ putStrLn $ "rebuilding database because " <> show e+ pure True+ Right (dbVersion, t) ->+ pure $+ diffUTCTime currentTime t > (7.5 * nominalDay)+ || dbVersion /= softwareVersion++-- | Download a feed and store it in the database.+updateFeed :: Connection -> FeedID -> IO ()+updateFeed conn feedID = do+ putStrLn $ "Updating National Vulnerability Database feed (" <> feedID <> ")"+ json <- downloadFeed feedID+ parsedCVEs <- either throwText pure $ parseFeed json+ putCVEs conn parsedCVEs++-- | Update the vulnerability database and run an action with a connection to+-- it.+withVulnDB :: (Connection -> IO a) -> IO a+withVulnDB action = do+ rebuild <- needsRebuild+ when rebuild rebuildDB+ withDB $ \conn -> do+ (_, lastUpdate) <- withDB getDBMeta+ currentTime <- getCurrentTime+ when (diffUTCTime currentTime lastUpdate > (0.25 * nominalDay)) $ do+ updateFeed conn "modified"+ markUpdated conn+ action conn++-- | Update a feed if it's older than a maximum age and return the contents as+-- ByteString.+downloadFeed :: FeedID -> IO BSL.ByteString+downloadFeed feed = do+ Meta _ expectedChecksum <- getMeta feed+ compressed <- simpleHttp $ feedURL feed ".json.gz"+ let raw = decompress compressed+ let actualChecksum = BSL.fromStrict $ hashlazy raw+ when (actualChecksum /= expectedChecksum) $+ throwString $+ "wrong hash, expected: "+ <> BSL.unpack (hex expectedChecksum)+ <> " got: "+ <> BSL.unpack (hex actualChecksum)+ return raw
+ src/NVDRules.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}++module NVDRules where++import CVE (CPE (..), CPEMatch (..), CVE (..))+import Data.Char (isDigit)+import qualified Data.Text as T+import OurPrelude+import Text.Regex.Applicative.Text (RE', anySym, many, psym, (=~))+import Utils (Boundary (..), ProductID, Version, VersionMatcher (..))++-- Return False to discard CVE+filter :: CVE -> CPEMatch -> ProductID -> Version -> Bool+filter _ cpeMatch "socat" v+ | cpeUpdatePresentAndNotPartOfVersion cpeMatch v = False -- TODO consider if this rule should be applied to all packages+filter _ cpeMatch "uzbl" v+ | isNothing (v =~ yearRegex)+ && "2009.12.22" `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch =+ False+ | isNothing (v =~ yearRegex)+ && "2010.04.03" `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch =+ False+filter _ cpeMatch "go" v+ | "." `T.isInfixOf` v+ && "-" `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch =+ False+filter _ cpeMatch "terraform" _+ | cpeTargetSoftware (cpeMatchCPE cpeMatch) == Just "aws" = False+filter cve _ "tor" _+ | cveID cve == "CVE-2017-16541" = False+filter _ cpeMatch "arena" _+ | cpeVendor (cpeMatchCPE cpeMatch) == Just "rockwellautomation"+ || cpeVendor (cpeMatchCPE cpeMatch) == Just "openforis" =+ False+filter _ cpeMatch "thrift" _+ | cpeVendor (cpeMatchCPE cpeMatch) == Just "facebook" = False+filter _ cpeMatch "kanboard" _+ | cpeTargetSoftware (cpeMatchCPE cpeMatch) == Just "jenkins" = False+filter _cve _match _productID _version = True++anyVersionInfixOf :: Text -> VersionMatcher -> Bool+anyVersionInfixOf t (SingleMatcher v) = t `T.isInfixOf` v+anyVersionInfixOf t (RangeMatcher (Including v1) (Including v2)) =+ t `T.isInfixOf` v1 || t `T.isInfixOf` v2+anyVersionInfixOf t (RangeMatcher (Excluding v1) (Excluding v2)) =+ t `T.isInfixOf` v1 || t `T.isInfixOf` v2+anyVersionInfixOf t (RangeMatcher (Including v1) (Excluding v2)) =+ t `T.isInfixOf` v1 || t `T.isInfixOf` v2+anyVersionInfixOf t (RangeMatcher (Excluding v1) (Including v2)) =+ t `T.isInfixOf` v1 || t `T.isInfixOf` v2+anyVersionInfixOf t (RangeMatcher Unbounded (Including v)) = t `T.isInfixOf` v+anyVersionInfixOf t (RangeMatcher Unbounded (Excluding v)) = t `T.isInfixOf` v+anyVersionInfixOf t (RangeMatcher (Including v) Unbounded) = t `T.isInfixOf` v+anyVersionInfixOf t (RangeMatcher (Excluding v) Unbounded) = t `T.isInfixOf` v+anyVersionInfixOf _ (RangeMatcher Unbounded Unbounded) = False++-- Four digits at the start followed by any number of anything else+yearRegex :: RE' ()+yearRegex =+ void $+ psym isDigit <* psym isDigit <* psym isDigit <* psym isDigit <* many anySym++cpeUpdatePresentAndNotPartOfVersion :: CPEMatch -> Version -> Bool+cpeUpdatePresentAndNotPartOfVersion cpeMatch v =+ maybe+ False+ (\update -> not (update `T.isInfixOf` v))+ (cpeUpdate (cpeMatchCPE cpeMatch))
src/Nix.hs view
@@ -1,190 +1,367 @@-{-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE TemplateHaskell #-} module Nix- ( nixEvalE- , compareVersions- , lookupAttrPath- , getDerivationFile- , getMaintainers- , getOldHash- , getSrcUrl- , getSrcUrls- , getIsBroken- , build- , getDescription- , cachix- , numberOfFetchers- , oldVersionOn- ) where+ ( assertNewerVersion,+ assertOldVersionOn,+ binPath,+ build,+ getAttr,+ getChangelog,+ getDerivationFile,+ getDescription,+ getDrvAttr,+ getHash,+ getHashFromBuild,+ getHomepage,+ getHomepageET,+ getIsBroken,+ getMaintainers,+ getOldHash,+ getOutpaths,+ getPatches,+ getSrcUrl,+ getSrcUrls,+ hasPatchNamed,+ hasUpdateScript,+ lookupAttrPath,+ nixEvalET,+ numberOfFetchers,+ numberOfHashes,+ parseStringList,+ resultLink,+ runUpdateScript,+ sha256Zero,+ version,+ Raw (..),+ )+where -import Control.Category ((>>>))-import Control.Error-import Control.Monad (void)-import Data.Bifunctor (second)-import Data.Function ((&))-import Data.Semigroup ((<>))-import Data.Text (Text)+import Data.Maybe (fromJust) import qualified Data.Text as T-import Prelude hiding (FilePath)-import Shelly (FilePath, Sh, cmd, fromText, run, setStdin, toTextIgnore)-import Utils (UpdateEnv(..), rewriteError, shE)+import qualified Data.Vector as V+import Language.Haskell.TH.Env (envQ)+import OurPrelude+import qualified Polysemy.Error as Error+import qualified System.Process.Typed as TP+import qualified Process+import qualified Process as P+import System.Exit+import Text.Parsec (parse)+import Text.Parser.Combinators+import Text.Parser.Token+import Utils (UpdateEnv (..), nixBuildOptions, nixCommonOptions, srcOrMain)+import Prelude hiding (log) +binPath :: String+binPath = fromJust ($$(envQ "NIX") :: Maybe String) <> "/bin"++data Env = Env [(String, String)]+ data Raw = Raw | NoRaw -rawOpt :: Raw -> [Text]+data EvalOptions = EvalOptions Raw Env++rawOpt :: Raw -> [String] rawOpt Raw = ["--raw"] rawOpt NoRaw = [] -nixEvalE :: Raw -> Text -> Sh (Either Text Text)-nixEvalE raw expr =- run "nix" (["eval", "-f", "."] <> rawOpt raw <> [expr]) &- (fmap T.strip >>> shE >>> rewriteError ("nix eval failed for " <> expr))+nixEvalSem ::+ Members '[P.Process, Error Text] r =>+ EvalOptions ->+ Text ->+ Sem r (Text, Text)+nixEvalSem (EvalOptions raw (Env env)) expr =+ (\(stdout, stderr) -> (T.strip stdout, T.strip stderr))+ <$> ourReadProcess_Sem+ (setEnv env (proc (binPath <> "/nix") (["eval", "-f", "."] <> rawOpt raw <> [T.unpack expr]))) +nixEvalET :: MonadIO m => EvalOptions -> Text -> ExceptT Text m Text+nixEvalET (EvalOptions raw (Env env)) expr =+ ourReadProcess_+ (setEnv env (proc (binPath <> "/nix") (["eval", "-f", "."] <> rawOpt raw <> [T.unpack expr])))+ & fmapRT (fst >>> T.strip)+ -- Error if the "new version" is actually newer according to nix-compareVersions :: UpdateEnv -> Sh (Either Text ())-compareVersions updateEnv = do+assertNewerVersion :: MonadIO m => UpdateEnv -> ExceptT Text m ()+assertNewerVersion updateEnv = do versionComparison <-- nixEvalE- NoRaw- ("(builtins.compareVersions \"" <> newVersion updateEnv <> "\" \"" <>- oldVersion updateEnv <>- "\")")- return $- case versionComparison of- Right "1" -> Right ()- Right a ->- Left $- newVersion updateEnv <> " is not newer than " <> oldVersion updateEnv <>- " according to Nix; versionComparison: " <>- a- Left a -> Left a- -- This is extremely slow but gives us the best results we know of+ nixEvalET+ (EvalOptions NoRaw (Env []))+ ( "(builtins.compareVersions \""+ <> newVersion updateEnv+ <> "\" \""+ <> oldVersion updateEnv+ <> "\")"+ )+ case versionComparison of+ "1" -> return ()+ a ->+ throwE+ ( newVersion updateEnv+ <> " is not newer than "+ <> oldVersion updateEnv+ <> " according to Nix; versionComparison: "+ <> a+ <> " "+ ) -lookupAttrPath :: UpdateEnv -> Sh (Either Text Text)+-- This is extremely slow but gives us the best results we know of+lookupAttrPath :: MonadIO m => UpdateEnv -> ExceptT Text m Text lookupAttrPath updateEnv =- cmd- "nix-env"- "-qa"- (packageName updateEnv <> "-" <> oldVersion updateEnv)- "-f"- "."- "--attr-path"- "--arg"- "config"- "{ allowBroken = true; allowUnfree = true; allowAliases = false; }" &- (fmap (head . T.words . head . T.lines) >>>- shE >>>- rewriteError "nix-env -q failed to find package name with old version")+ proc+ (binPath <> "/nix-env")+ ( [ "-qa",+ (packageName updateEnv <> "-" <> oldVersion updateEnv) & T.unpack,+ "-f",+ ".",+ "--attr-path"+ ]+ <> nixCommonOptions+ )+ & ourReadProcess_+ & fmapRT (fst >>> T.lines >>> head >>> T.words >>> head) -getDerivationFile :: UpdateEnv -> Text -> Sh (Either Text FilePath)-getDerivationFile updateEnv attrPath =- cmd "env" "EDITOR=echo" "nix" "edit" attrPath "-f" "." &- (fmap T.strip >>>- fmap fromText >>> shE >>> rewriteError "Couldn't find derivation file.")+getDerivationFile :: MonadIO m => Text -> ExceptT Text m FilePath+getDerivationFile attrPath =+ proc "env" ["EDITOR=echo", (binPath <> "/nix"), "edit", attrPath & T.unpack, "-f", "."]+ & ourReadProcess_+ & fmapRT (fst >>> T.strip >>> T.unpack) -getHash :: Text -> Sh (Either Text Text)-getHash attrPath =- nixEvalE Raw ("pkgs." <> attrPath <> ".src.drvAttrs.outputHash")+getDrvAttr :: MonadIO m => Text -> Text -> ExceptT Text m Text+getDrvAttr drvAttr =+ srcOrMain+ (\attrPath -> nixEvalET (EvalOptions Raw (Env [])) ("pkgs." <> attrPath <> ".drvAttrs." <> drvAttr)) -getOldHash :: Text -> Sh (Either Text Text)-getOldHash attrPath =- getHash attrPath &- rewriteError- ("Could not find old output hash at " <> attrPath <>- ".src.drvAttrs.outputHash.")+-- Get an attribute that can be evaluated off a derivation, as in:+-- getAttr "cargoSha256" "ripgrep" -> 0lwz661rbm7kwkd6mallxym1pz8ynda5f03ynjfd16vrazy2dj21+getAttr :: MonadIO m => Raw -> Text -> Text -> ExceptT Text m Text+getAttr raw attr =+ srcOrMain+ (\attrPath -> nixEvalET (EvalOptions raw (Env [])) (attrPath <> "." <> attr)) -getSrcUrl :: Text -> Sh (Either Text Text)-getSrcUrl attrPath =- nixEvalE- Raw- ("(let pkgs = import ./. {}; in builtins.elemAt pkgs." <> attrPath <>- ".src.drvAttrs.urls 0)")+getHash :: MonadIO m => Text -> ExceptT Text m Text+getHash =+ srcOrMain+ (\attrPath -> nixEvalET (EvalOptions Raw (Env [])) ("pkgs." <> attrPath <> ".drvAttrs.outputHash")) -getMaintainers :: Text -> Sh (Either Text Text)+getOldHash :: MonadIO m => Text -> ExceptT Text m Text+getOldHash attrPath =+ getHash attrPath++getMaintainers :: MonadIO m => Text -> ExceptT Text m Text getMaintainers attrPath =- nixEvalE- Raw- ("(let pkgs = import ./. {}; gh = m : m.github or \"\"; nonempty = s: s != \"\"; addAt = s: \"@\"+s; in builtins.concatStringsSep \" \" (map addAt (builtins.filter nonempty (map gh pkgs." <>- attrPath <>- ".meta.maintainers or []))))") &- rewriteError ("Could not fetch maintainers for" <> attrPath)+ nixEvalET+ (EvalOptions Raw (Env []))+ ( "(let pkgs = import ./. {}; gh = m : m.github or \"\"; nonempty = s: s != \"\"; addAt = s: \"@\"+s; in builtins.concatStringsSep \" \" (map addAt (builtins.filter nonempty (map gh pkgs."+ <> attrPath+ <> ".meta.maintainers or []))))"+ ) -readNixBool :: Either Text Text -> Either Text Bool-readNixBool (Right "true") = Right True-readNixBool (Right "false") = Right False-readNixBool (Right a) = Left ("Failed to convert expected nix boolean " <> a)-readNixBool (Left e) = Left e+parseStringList :: MonadIO m => Text -> ExceptT Text m (Vector Text)+parseStringList list =+ parse nixStringList ("nix list " ++ T.unpack list) list & fmapL tshow+ & hoistEither -getIsBroken :: Text -> Sh (Either Text Bool)+nixStringList :: TokenParsing m => m (Vector Text)+nixStringList = V.fromList <$> brackets (many stringLiteral)++getOutpaths :: MonadIO m => Text -> ExceptT Text m (Vector Text)+getOutpaths attrPath = do+ list <- nixEvalET (EvalOptions NoRaw (Env [("GC_INITIAL_HEAP_SIZE", "10g")])) (attrPath <> ".outputs")+ outputs <- parseStringList list+ V.sequence $ fmap (\o -> nixEvalET (EvalOptions Raw (Env [])) (attrPath <> "." <> o)) outputs++readNixBool :: MonadIO m => ExceptT Text m Text -> ExceptT Text m Bool+readNixBool t = do+ text <- t+ case text of+ "true" -> return True+ "false" -> return False+ a -> throwE ("Failed to read expected nix boolean " <> a <> " ")++getIsBroken :: MonadIO m => Text -> ExceptT Text m Bool getIsBroken attrPath =- nixEvalE- NoRaw- ("(let pkgs = import ./. {}; in pkgs." <> attrPath <>- ".meta.broken or false)") &- fmap readNixBool &- rewriteError ("Could not get meta.broken for attrpath " <> attrPath)+ nixEvalET+ (EvalOptions NoRaw (Env []))+ ( "(let pkgs = import ./. {}; in pkgs."+ <> attrPath+ <> ".meta.broken or false)"+ )+ & readNixBool -getDescription :: Text -> Sh (Either Text Text)+getChangelog :: MonadIO m => Text -> ExceptT Text m Text+getChangelog attrPath =+ nixEvalET+ (EvalOptions NoRaw (Env []))+ ( "(let pkgs = import ./. {}; in pkgs."+ <> attrPath+ <> ".meta.changelog or \"\")"+ )++getDescription :: MonadIO m => Text -> ExceptT Text m Text getDescription attrPath =- nixEvalE- NoRaw- ("(let pkgs = import ./. {}; in pkgs." <> attrPath <>- ".meta.description or \"\")") &- rewriteError ("Could not get meta.description for attrpath " <> attrPath)+ nixEvalET+ (EvalOptions NoRaw (Env []))+ ( "(let pkgs = import ./. {}; in pkgs."+ <> attrPath+ <> ".meta.description or \"\")"+ ) -getSrcAttr :: Text -> Text -> Sh (Either Text Text)-getSrcAttr attr attrPath =- nixEvalE NoRaw ("pkgs." <> attrPath <> ".src." <> attr)+getHomepage ::+ Members '[P.Process, Error Text] r =>+ Text ->+ Sem r Text+getHomepage attrPath =+ fst <$> nixEvalSem+ (EvalOptions NoRaw (Env []))+ ( "(let pkgs = import ./. {}; in pkgs."+ <> attrPath+ <> ".meta.homepage or \"\")"+ ) -getSrcUrls :: Text -> Sh (Either Text Text)+getHomepageET :: MonadIO m => Text -> ExceptT Text m Text+getHomepageET attrPath =+ ExceptT+ . liftIO+ . runFinal+ . embedToFinal+ . Error.runError+ . Process.runIO+ $ getHomepage attrPath++getSrcUrl :: MonadIO m => Text -> ExceptT Text m Text+getSrcUrl =+ srcOrMain+ ( \attrPath ->+ nixEvalET+ (EvalOptions Raw (Env []))+ ( "(let pkgs = import ./. {}; in builtins.elemAt pkgs."+ <> attrPath+ <> ".drvAttrs.urls 0)"+ )+ )++getSrcAttr :: MonadIO m => Text -> Text -> ExceptT Text m Text+getSrcAttr attr =+ srcOrMain (\attrPath -> nixEvalET (EvalOptions NoRaw (Env [])) ("pkgs." <> attrPath <> "." <> attr))++getSrcUrls :: MonadIO m => Text -> ExceptT Text m Text getSrcUrls = getSrcAttr "urls" -build :: Text -> Sh (Either Text ())-build attrPath = do- buildE <-- shE $- cmd- "nix-build"- "--option"- "sandbox"- "true"- "--option"- "restrict-eval"- "true"- "-A"- attrPath- case buildE of- Right _ -> return $ Right ()- Left _ -> do- buildLogE <-- cmd "nix" "log" "-f" "." attrPath &- (shE >>>- (fmap . fmap)- (T.lines >>> reverse >>> take 30 >>> reverse >>> T.unlines))- return $- case buildLogE of- Left t -> Left "nix log failed trying to get build logs"- Right buildLog -> Left ("nix build failed.\n" <> buildLog)+buildCmd :: Text -> ProcessConfig () () ()+buildCmd attrPath =+ silently $ proc (binPath <> "/nix-build") (nixBuildOptions ++ ["-A", attrPath & T.unpack]) -cachix :: FilePath -> Sh ()-cachix resultPath = do- setStdin (toTextIgnore resultPath)- void $ shE $ cmd "cachix" "push" "r-ryantm"+log :: Text -> ProcessConfig () () ()+log attrPath = proc (binPath <> "/nix") ["log", "-f", ".", attrPath & T.unpack] +build :: MonadIO m => Text -> ExceptT Text m ()+build attrPath =+ (buildCmd attrPath & runProcess_ & tryIOTextET)+ <|> ( do+ _ <- buildFailedLog+ throwE "nix log failed trying to get build logs "+ )+ where+ buildFailedLog = do+ buildLog <-+ ourReadProcessInterleaved_ (log attrPath)+ & fmap (T.lines >>> reverse >>> take 30 >>> reverse >>> T.unlines)+ throwE ("nix build failed.\n" <> buildLog <> " ")+ numberOfFetchers :: Text -> Int numberOfFetchers derivationContents =- count "fetchurl {" + count "fetchgit {" + count "fetchFromGitHub {"+ countUp "fetchurl {" + countUp "fetchgit {" + countUp "fetchFromGitHub {" where- count x = T.count x derivationContents+ countUp x = T.count x derivationContents -oldVersionOn :: UpdateEnv -> Text -> Text -> Sh (Either Text ())-oldVersionOn updateEnv branchName contents =- pure- (assertErr- ("Old version not present in " <> branchName <> " derivation file.")- (oldVersion updateEnv `T.isInfixOf` contents))+-- Sum the number of things that look like fixed-output derivation hashes+numberOfHashes :: Text -> Int+numberOfHashes derivationContents =+ sum $ map countUp ["sha256 =", "sha256=", "cargoSha256 =", "vendorSha256 ="]+ where+ countUp x = T.count x derivationContents++assertOldVersionOn ::+ MonadIO m => UpdateEnv -> Text -> Text -> ExceptT Text m ()+assertOldVersionOn updateEnv branchName contents =+ tryAssert+ ("Old version " <> oldVersionPattern <> " not present in " <> branchName <> " derivation file with contents: " <> contents)+ (oldVersionPattern `T.isInfixOf` contents)+ where+ oldVersionPattern = oldVersion updateEnv <> "\""++resultLink :: MonadIO m => ExceptT Text m Text+resultLink =+ T.strip+ <$> ( ourReadProcessInterleaved_ "readlink ./result"+ <|> ourReadProcessInterleaved_ "readlink ./result-bin"+ )+ <|> throwE "Could not find result link. "++sha256Zero :: Text+sha256Zero = "0000000000000000000000000000000000000000000000000000"++-- fixed-output derivation produced path '/nix/store/fg2hz90z5bc773gpsx4gfxn3l6fl66nw-source' with sha256 hash '0q1lsgc1621czrg49nmabq6am9sgxa9syxrwzlksqqr4dyzw4nmf' instead of the expected hash '0bp22mzkjy48gncj5vm9b7whzrggcbs5pd4cnb6k8jpl9j02dhdv'+getHashFromBuild :: MonadIO m => Text -> ExceptT Text m Text+getHashFromBuild =+ srcOrMain+ ( \attrPath -> do+ (exitCode, _, stderr) <- buildCmd attrPath & readProcess+ when (exitCode == ExitSuccess) $ throwE "build succeeded unexpectedly"+ let stdErrText = bytestringToText stderr+ let firstSplit = T.splitOn "got: " stdErrText+ firstSplitSecondPart <-+ tryAt+ ("stderr did not split as expected full stderr was: \n" <> stdErrText)+ firstSplit+ 1+ let secondSplit = T.splitOn "\n" firstSplitSecondPart+ tryHead+ ( "stderr did not split second part as expected full stderr was: \n"+ <> stdErrText+ <> "\nfirstSplitSecondPart:\n"+ <> firstSplitSecondPart+ )+ secondSplit+ )++version :: MonadIO m => ExceptT Text m Text+version = ourReadProcessInterleaved_ (proc (binPath <> "/nix") ["--version"])++getPatches :: MonadIO m => Text -> ExceptT Text m Text+getPatches attrPath =+ nixEvalET+ (EvalOptions NoRaw (Env []))+ ( "(let pkgs = import ./. {}; in (map (p: p.name) pkgs."+ <> attrPath+ <> ".patches))"+ )++hasPatchNamed :: MonadIO m => Text -> Text -> ExceptT Text m Bool+hasPatchNamed attrPath name = do+ ps <- getPatches attrPath+ return $ name `T.isInfixOf` ps++hasUpdateScript :: MonadIO m => Text -> ExceptT Text m Bool+hasUpdateScript attrPath = do+ result <-+ nixEvalET+ (EvalOptions NoRaw (Env []))+ ( "(let pkgs = import ./. {}; in builtins.hasAttr \"updateScript\" pkgs."+ <> attrPath+ <> ")"+ )+ case result of+ "true" -> return True+ _ -> return False++runUpdateScript :: MonadIO m => Text -> ExceptT Text m (ExitCode, Text)+runUpdateScript attrPath = do+ ourReadProcessInterleaved $+ TP.setStdin (TP.byteStringInput "\n") $+ proc "nix-shell" ["maintainers/scripts/update.nix", "--argstr", "package", T.unpack attrPath]
+ src/NixpkgsReview.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module NixpkgsReview+ ( cacheDir,+ runReport,+ )+where++import Data.Maybe (fromJust)+import Data.Text as T+import qualified File as F+import Language.Haskell.TH.Env (envQ)+import OurPrelude+import Polysemy.Output (Output, output)+import qualified Process as P+import System.Environment.XDG.BaseDir (getUserCacheDir)+import System.Exit (ExitCode (..))+import qualified Utils+import Prelude hiding (log)++binPath :: String+binPath = fromJust ($$(envQ "NIXPKGSREVIEW") :: Maybe String) <> "/bin"++cacheDir :: IO FilePath+cacheDir = getUserCacheDir "nixpkgs-review"++revDir :: FilePath -> Text -> FilePath+revDir cache commit = cache <> "/rev-" <> T.unpack commit++run ::+ Members '[F.File, P.Process, Output Text] r =>+ FilePath ->+ Text ->+ Sem r Text+run cache commit = let timeout = "45m" :: Text in do+ -- TODO: probably just skip running nixpkgs-review if the directory+ -- already exists+ void $+ ourReadProcessInterleavedSem $+ proc "rm" ["-rf", revDir cache commit]+ (exitCode, _nixpkgsReviewOutput) <-+ ourReadProcessInterleavedSem $+ proc "timeout" [T.unpack timeout, (binPath <> "/nixpkgs-review"), "rev", T.unpack commit, "--no-shell"]+ case exitCode of+ ExitFailure 124 -> do+ output $ "[check][nixpkgs-review] took longer than " <> timeout <> " and timed out"+ return $ "nixpkgs-review took longer than " <> timeout <> " and timed out"+ _ -> F.read $ (revDir cache commit) <> "/report.md"++-- Assumes we are already in nixpkgs dir+runReport :: (Text -> IO ()) -> Text -> IO Text+runReport log commit = do+ log "[check][nixpkgs-review]"+ c <- cacheDir+ msg <-+ runFinal+ . embedToFinal+ . F.runIO+ . P.runIO+ . Utils.runLog log+ $ NixpkgsReview.run c commit+ log msg+ return msg
+ src/OurPrelude.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE PartialTypeSignatures #-}++module OurPrelude+ ( (>>>),+ (<|>),+ (<>),+ (<&>),+ (&),+ module Control.Error,+ module Control.Monad.Except,+ module Control.Monad.Trans.Class,+ module Control.Monad.IO.Class,+ module Data.Bifunctor,+ module System.Process.Typed,+ module Polysemy,+ module Polysemy.Error,+ Set,+ Text,+ Vector,+ interpolate,+ tshow,+ tryIOTextET,+ whenM,+ ourReadProcess_,+ ourReadProcess_Sem,+ ourReadProcessInterleaved_,+ ourReadProcessInterleavedBS_,+ ourReadProcessInterleaved,+ ourReadProcessInterleaved_Sem,+ ourReadProcessInterleavedSem,+ silently,+ bytestringToText,+ )+where++import Control.Applicative ((<|>))+import Control.Category ((>>>))+import Control.Error+import Control.Monad.Except+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Bifunctor+import qualified Data.ByteString.Lazy as BSL+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Set (Set)+import Data.Text (Text, pack)+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T+import Data.Vector (Vector)+import Language.Haskell.TH.Quote+import qualified NeatInterpolation+import Polysemy+import Polysemy.Error hiding (note, try, tryJust)+import qualified Process as P+import System.Exit+import System.Process.Typed++interpolate :: QuasiQuoter+interpolate = NeatInterpolation.text++tshow :: Show a => a -> Text+tshow = show >>> pack++tryIOTextET :: MonadIO m => IO a -> ExceptT Text m a+tryIOTextET = syncIO >>> fmapLT tshow++whenM :: Monad m => m Bool -> m () -> m ()+whenM c a = c >>= \res -> when res a++bytestringToText :: BSL.ByteString -> Text+bytestringToText = BSL.toStrict >>> (T.decodeUtf8With T.lenientDecode)++ourReadProcessInterleavedBS_ ::+ MonadIO m =>+ ProcessConfig stdin stdoutIgnored stderrIgnored ->+ ExceptT Text m BSL.ByteString+ourReadProcessInterleavedBS_ = readProcessInterleaved_ >>> tryIOTextET++ourReadProcess_ ::+ MonadIO m =>+ ProcessConfig stdin stdout stderr ->+ ExceptT Text m (Text, Text)+ourReadProcess_ = readProcess_ >>> tryIOTextET >>> fmapRT (\(stdout,stderr) -> (bytestringToText stdout, bytestringToText stderr))++ourReadProcess_Sem ::+ Members '[P.Process] r =>+ ProcessConfig stdin stdoutIgnored stderrIgnored ->+ Sem r (Text, Text)+ourReadProcess_Sem =+ P.read_ >>> fmap (\(stdout,stderr) -> (bytestringToText stdout, bytestringToText stderr))++ourReadProcessInterleaved_ ::+ MonadIO m =>+ ProcessConfig stdin stdoutIgnored stderrIgnored ->+ ExceptT Text m Text+ourReadProcessInterleaved_ =+ readProcessInterleaved_ >>> tryIOTextET >>> fmapRT bytestringToText++ourReadProcessInterleaved_Sem ::+ Members '[P.Process] r =>+ ProcessConfig stdin stdoutIgnored stderrIgnored ->+ Sem r Text+ourReadProcessInterleaved_Sem =+ P.readInterleaved_ >>> fmap bytestringToText++ourReadProcessInterleaved ::+ MonadIO m =>+ ProcessConfig stdin stdoutIgnored stderrIgnored ->+ ExceptT Text m (ExitCode, Text)+ourReadProcessInterleaved =+ readProcessInterleaved+ >>> tryIOTextET+ >>> fmapRT (\(a, b) -> (a, bytestringToText b))++ourReadProcessInterleavedSem ::+ Members '[P.Process] r =>+ ProcessConfig stdin stdoutIgnored stderrIgnored ->+ Sem r (ExitCode, Text)+ourReadProcessInterleavedSem =+ P.readInterleaved+ >>> fmap (\(a, b) -> (a, bytestringToText b))++silently :: ProcessConfig stdin stdout stderr -> ProcessConfig () () ()+silently = setStderr closed >>> setStdin closed >>> setStdout closed
src/Outpaths.hs view
@@ -1,25 +1,35 @@-{-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-} module Outpaths+ ( currentOutpathSet,+ ResultLine,+ dummyOutpathSetBefore,+ dummyOutpathSetAfter,+ numPackageRebuilds,+ outpathReport,+ ) where -import Data.Semigroup ((<>))-import Data.Text (Text)+import Data.List (sort)+import qualified Data.Set as S import qualified Data.Text as T-import NeatInterpolation (text)-import Shelly-import Utils-default (Text)--outPathsExpr = [text|+import qualified Data.Text.IO as T+import qualified Data.Vector as V+import OurPrelude+import Text.Parsec (parse)+import Text.Parser.Char+import Text.Parser.Combinators -(let- lib = import ./lib;- hydraJobs = import ./pkgs/top-level/release.nix+outPathsExpr :: Text+outPathsExpr =+ [interpolate|+{ checkMeta+, path ? ./.+}:+let+ lib = import (path + "/lib");+ hydraJobs = import (path + "/pkgs/top-level/release.nix") # Compromise: accuracy vs. resources needed for evaluation. { supportedSystems = [@@ -34,10 +44,14 @@ allowBroken = true; allowUnfree = true; allowInsecurePredicate = x: true;- checkMeta = true;+ checkMeta = checkMeta; handleEvalIssue = reason: errormsg:- if reason == "unknown-meta"+ let+ fatalErrors = [+ "unknown-meta" "broken-outputs"+ ];+ in if builtins.elem reason fatalErrors then abort errormsg else true; @@ -66,14 +80,114 @@ ]; in- tweak (builtins.removeAttrs hydraJobs blacklist))+ tweak (builtins.removeAttrs hydraJobs blacklist) |] ---downloadOutPath :: Sh ()+outPath :: MonadIO m => ExceptT Text m Text+outPath = do+ liftIO $ putStrLn "Writing outpaths.nix..."+ liftIO $ T.writeFile "./outpaths.nix" outPathsExpr+ liftIO $ putStrLn "Evaluating outpaths..."+ ourReadProcessInterleaved_+ "nix-env -f ./outpaths.nix -qaP --no-name --out-path --arg checkMeta true --show-trace" -outPath :: Sh Text-outPath = sub $ do- Utils.setupNixpkgs- cmd "curl" "-o" "outpaths.nix" "https://raw.githubusercontent.com/NixOS/ofborg/released/ofborg/src/outpaths.nix"- setenv "GC_INITIAL_HEAP_SIZE" "4g"- cmd "nix-env" "-f" "./outpaths.nix" "-qaP" "--no-name" "--out-path" "--arg" "checkMeta" "true"+data Outpath = Outpath+ { mayName :: Maybe Text,+ storePath :: Text+ }+ deriving (Eq, Ord, Show)++data ResultLine = ResultLine+ { package :: Text,+ architecture :: Text,+ outpaths :: Vector Outpath+ }+ deriving (Eq, Ord, Show)++-- Example query result line:+-- testInput :: Text+-- testInput =+-- "haskellPackages.amazonka-dynamodb-streams.x86_64-linux doc=/nix/store/m4rpsc9nx0qcflh9ni6qdlg6hbkwpicc-amazonka-dynamodb-streams-1.6.0-doc;/nix/store/rvd4zydr22a7j5kgnmg5x6695c7bgqbk-amazonka-dynamodb-streams-1.6.0\nhaskellPackages.agum.x86_64-darwin doc=/nix/store/n526rc0pa5h0krdzsdni5agcpvcd3cb9-agum-2.7-doc;/nix/store/s59r75svbjm724q5iaprq4mln5k6wcr9-agum-2.7"+currentOutpathSet :: MonadIO m => ExceptT Text m (Set ResultLine)+currentOutpathSet = do+ op <- outPath+ parse parseResults "outpath" op & fmapL tshow & hoistEither++dummyOutpathSetBefore :: Text -> Set ResultLine+dummyOutpathSetBefore attrPath = S.singleton (ResultLine attrPath "x86-64" (V.singleton (Outpath (Just "attrPath") "fakepath")))++dummyOutpathSetAfter :: Text -> Set ResultLine+dummyOutpathSetAfter attrPath = S.singleton (ResultLine attrPath "x86-64" (V.singleton (Outpath (Just "attrPath") "fakepath-edited")))++parseResults :: CharParsing m => m (Set ResultLine)+parseResults = S.fromList <$> parseResultLine `sepEndBy` newline++parseResultLine :: CharParsing m => m ResultLine+parseResultLine =+ ResultLine <$> (T.dropWhileEnd (== '.') <$> parseAttrpath)+ <*> parseArchitecture+ <* spaces+ <*> parseOutpaths++parseAttrpath :: CharParsing m => m Text+parseAttrpath = T.concat <$> many (try parseAttrpathPart)++parseAttrpathPart :: CharParsing m => m Text+parseAttrpathPart = T.snoc <$> (T.pack <$> many (noneOf ". ")) <*> char '.'++parseArchitecture :: CharParsing m => m Text+parseArchitecture = T.pack <$> many (noneOf " ")++parseOutpaths :: CharParsing m => m (Vector Outpath)+parseOutpaths = V.fromList <$> (parseOutpath `sepBy1` char ';')++parseOutpath :: CharParsing m => m Outpath+parseOutpath =+ Outpath <$> optional (try (T.pack <$> (many (noneOf "=\n") <* char '=')))+ <*> (T.pack <$> many (noneOf ";\n"))++packageRebuilds :: Set ResultLine -> Vector Text+packageRebuilds = S.toList >>> fmap package >>> sort >>> V.fromList >>> V.uniq++numPackageRebuilds :: Set ResultLine -> Int+numPackageRebuilds diff = V.length $ packageRebuilds diff++archRebuilds :: Text -> Set ResultLine -> Int+archRebuilds arch =+ S.toList >>> fmap architecture >>> filter (== arch) >>> length++darwinRebuilds :: Set ResultLine -> Int+darwinRebuilds = archRebuilds "x86_64-darwin"++linuxRebuilds :: Set ResultLine -> Int+linuxRebuilds = archRebuilds "x86_64-linux"++linux32bRebuilds :: Set ResultLine -> Int+linux32bRebuilds = archRebuilds "i686-linux"++armRebuilds :: Set ResultLine -> Int+armRebuilds = archRebuilds "aarch64-linux"++outpathReport :: Set ResultLine -> Text+outpathReport diff =+ let pkg = tshow $ V.length $ packageRebuilds diff+ firstFifty = T.unlines $ V.toList $ V.take 50 $ packageRebuilds diff+ darwin = tshow $ darwinRebuilds diff+ linux = tshow $ linuxRebuilds diff+ linux32b = tshow $ linux32bRebuilds diff+ arm = tshow $ armRebuilds diff+ numPaths = tshow $ S.size diff+ in [interpolate|+ $numPaths total rebuild path(s)++ $pkg package rebuild(s)++ $linux x86_64-linux rebuild(s)+ $linux32b i686-linux rebuild(s)+ $darwin x86_64-darwin rebuild(s)+ $arm aarch64-linux rebuild(s)+++ First fifty rebuilds by attrpath+ $firstFifty+ |]
+ src/Process.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Process where++import qualified Data.ByteString.Lazy as BSL+import Polysemy+import Polysemy.Input+import System.Exit (ExitCode (..))+import qualified System.Process.Typed as TP++data Process m a where+ Read_ :: TP.ProcessConfig stdin stdout stderr -> Process m (BSL.ByteString, BSL.ByteString)+ ReadInterleaved_ :: TP.ProcessConfig stdin stdout stderr -> Process m BSL.ByteString+ ReadInterleaved :: TP.ProcessConfig stdin stdout stderr -> Process m (ExitCode, BSL.ByteString)++makeSem ''Process++runIO ::+ Member (Embed IO) r =>+ Sem (Process ': r) a ->+ Sem r a+runIO =+ interpret $ \case+ Read_ config -> embed $ (TP.readProcess_ config)+ ReadInterleaved_ config -> embed $ (TP.readProcessInterleaved_ config)+ ReadInterleaved config -> embed $ (TP.readProcessInterleaved config)++runPure ::+ [BSL.ByteString] ->+ Sem (Process ': r) a ->+ Sem r a+runPure outputList =+ runInputList outputList+ . reinterpret \case+ Read_ _config -> do+ r <- maybe "" id <$> input+ return (r, "")+ ReadInterleaved_ _config -> maybe "" id <$> input+ ReadInterleaved _config -> do+ r <- maybe "" id <$> input+ return (ExitSuccess, r)
+ src/Repology.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Repology where++import Data.Aeson+import Data.HashMap.Strict+import Data.List+import Data.Proxy+import qualified Data.Text as T+import qualified Data.Text.IO+import qualified Data.Vector as V+import GHC.Generics+import Network.HTTP.Client.TLS (newTlsManager)+import OurPrelude+import Servant.API+import Servant.Client (BaseUrl (..), mkClientEnv, ClientM, Scheme (..), client, runClientM)+import System.IO++baseUrl :: BaseUrl+baseUrl = BaseUrl Https "repology.org" 443 "/api/v1"++type Metapackage = Vector Package++compareMetapackage :: Metapackage -> Metapackage -> Ordering+compareMetapackage ps1 ps2 = compareMetapackage' (ps1 V.!? 0) (ps2 V.!? 0)+ where+ compareMetapackage' (Just p1) (Just p2) = compare (name p1) (name p2)+ compareMetapackage' Nothing (Just _) = LT+ compareMetapackage' (Just _) Nothing = GT+ compareMetapackage' _ _ = EQ++type Metapackages = HashMap Text Metapackage++type API =+ "metapackage" :> Capture "metapackage_name" Text :> Get '[JSON] Metapackage :<|> "metapackages" :> QueryParam "search" Text :> QueryParam "maintainers" Text :> QueryParam "category" Text :> QueryParam "inrepo" Text :> QueryParam "outdated" Bool :> QueryParam "notinrepo" Text :> QueryParam "minspread" Integer :> QueryParam "maxspread" Integer :> Get '[JSON] Metapackages :<|> "metapackages" :> Capture "name" Text :> QueryParam "search" Text :> QueryParam "maintainers" Text :> QueryParam "category" Text :> QueryParam "inrepo" Text :> QueryParam "outdated" Bool :> QueryParam "notinrepo" Text :> QueryParam "minspread" Integer :> QueryParam "maxspread" Integer :> Get '[JSON] Metapackages++data Package = Package+ { repo :: Text,+ name :: Maybe Text,+ version :: Text,+ origversion :: Maybe Text,+ status :: Maybe Text,+ summary :: Maybe Text,+ categories :: Maybe (Vector Text),+ licenses :: Maybe (Vector Text),+ www :: Maybe (Vector Text),+ downloads :: Maybe (Vector Text)+ }+ deriving (Eq, Show, Generic, FromJSON)++api :: Proxy API+api = Proxy++metapackage :: Text -> ClientM (Vector Package)++metapackages ::+ Maybe Text ->+ Maybe Text ->+ Maybe Text ->+ Maybe Text ->+ Maybe Bool ->+ Maybe Text ->+ Maybe Integer ->+ Maybe Integer ->+ ClientM Metapackages++metapackages' ::+ Text ->+ Maybe Text ->+ Maybe Text ->+ Maybe Text ->+ Maybe Text ->+ Maybe Bool ->+ Maybe Text ->+ Maybe Integer ->+ Maybe Integer ->+ ClientM Metapackages+metapackage :<|> metapackages :<|> metapackages' = client api++-- type PagingResult = PagingResult (Vector Metapackage, ClientM PagingResult)+-- metapackages :: Text -> ClientM PagingResult+-- metapackages n = do+-- m <- ms n+-- return (lastMetapackageName m, sortedMetapackages m)+lastMetapackageName :: Metapackages -> Maybe Text+lastMetapackageName = keys >>> sort >>> Prelude.reverse >>> headMay++sortedMetapackages :: Metapackages -> Vector Metapackage+sortedMetapackages = elems >>> sortBy compareMetapackage >>> V.fromList++nixRepo :: Text+nixRepo = "nix_unstable"++nixOutdated :: ClientM Metapackages+nixOutdated =+ metapackages+ Nothing+ Nothing+ Nothing+ (Just nixRepo)+ (Just True)+ Nothing+ Nothing+ Nothing++nextNixOutdated :: Text -> ClientM Metapackages+nextNixOutdated n =+ metapackages'+ n+ Nothing+ Nothing+ Nothing+ (Just nixRepo)+ (Just True)+ Nothing+ Nothing+ Nothing++outdatedForRepo :: Text -> Vector Package -> Maybe Package+outdatedForRepo r =+ V.find (\p -> (status p) == Just "outdated" && (repo p) == r)++newest :: Vector Package -> Maybe Package+newest = V.find (\p -> (status p) == Just "newest")++dropMaybes :: [(Maybe Package, Maybe Package)] -> [(Package, Package)]+dropMaybes = Data.List.foldl' twoJusts []+ where+ twoJusts a (Just o, Just n) = (o, n) : a+ twoJusts a _ = a++getUpdateInfo :: ClientM (Maybe Text, Bool, Vector (Package, Package))+getUpdateInfo = do+ outdated <- nixOutdated+ let ms = elems outdated+ let nixPackages = fmap (outdatedForRepo nixRepo) ms+ let newestPackages = fmap newest ms+ let nixNew = dropMaybes (zip nixPackages newestPackages)+ let mLastName = lastMetapackageName outdated+ liftIO $ hPutStrLn stderr $ show mLastName+ liftIO $ hPutStrLn stderr $ show (length ms)+ return (mLastName, length ms /= 1, V.fromList nixNew)++-- let sorted = sortBy (\(p1,_) (p2,_) -> compare (name p1) (name p2)) nixNew+getNextUpdateInfo ::+ Text -> ClientM (Maybe Text, Bool, Vector (Package, Package))+getNextUpdateInfo n = do+ outdated <- nextNixOutdated n+ let ms = elems outdated+ let nixPackages = fmap (outdatedForRepo nixRepo) ms+ let newestPackages = fmap newest ms+ let nixNew = dropMaybes (zip nixPackages newestPackages)+ let mLastName = lastMetapackageName outdated+ liftIO $ hPutStrLn stderr $ show mLastName+ liftIO $ hPutStrLn stderr $ show (length ms)+ return (mLastName, length ms /= 1, V.fromList nixNew)++repologyUrl :: Text -> Text+repologyUrl pname = "https://repology.org/metapackage/" <> pname <> "/versions"++-- let sorted = sortBy (\(p1,_) (p2,_) -> compare (name p1) (name p2)) nixNew+updateInfo :: (Package, Package) -> Maybe Text+updateInfo (outdated, newestP) = do+ pname <- name outdated+ pure $ T.unwords [pname, version outdated, version newestP, repologyUrl pname]++justs :: Vector (Maybe a) -> Vector a+justs = V.concatMap (maybeToList >>> V.fromList)++moreNixUpdateInfo ::+ (Maybe Text, Vector (Package, Package)) ->+ ClientM (Vector (Package, Package))+moreNixUpdateInfo (Nothing, acc) = do+ (mLastName, moreWork, newNix) <- getUpdateInfo+ liftIO $+ V.sequence_ $+ fmap Data.Text.IO.putStrLn $+ justs $+ fmap updateInfo newNix+ if moreWork+ then moreNixUpdateInfo (mLastName, newNix V.++ acc)+ else return acc+moreNixUpdateInfo (Just pname, acc) = do+ (mLastName, moreWork, newNix) <- getNextUpdateInfo pname+ liftIO $+ V.sequence_ $+ fmap Data.Text.IO.putStrLn $+ justs $+ fmap updateInfo newNix+ if moreWork+ then moreNixUpdateInfo (mLastName, newNix V.++ acc)+ else return acc++allNixUpdateInfo :: ClientM (Vector (Package, Package))+allNixUpdateInfo = moreNixUpdateInfo (Nothing, V.empty)++fetch :: IO ()+fetch = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering+ liftIO $ hPutStrLn stderr "starting"+ manager' <- newTlsManager+ e <- runClientM allNixUpdateInfo (mkClientEnv manager' baseUrl)+ case e of+ Left ce -> liftIO $ hPutStrLn stderr $ show ce+ Right _ -> liftIO $ hPutStrLn stderr $ "done"+ return ()
+ src/Rewrite.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Rewrite+ ( Args (..),+ runAll,+ golangModuleVersion,+ quotedUrls,+ quotedUrlsET,+ rustCrateVersion,+ version,+ redirectedUrls,+ )+where++import qualified Data.Text as T+import Data.Text.Encoding as T+import Data.Text.Encoding.Error as T+import Data.Text.IO as T+import qualified File+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Types.Status (statusCode)+import qualified Nix+import OurPrelude+import qualified Polysemy.Error as Error+import Polysemy.Output (Output, output)+import qualified Process+import System.Exit+import Utils (UpdateEnv (..))+import qualified Utils+ ( runLog,+ stripQuotes,+ )+import Prelude hiding (log)++{-+ This module contains rewrite functions that make some modification to the+ nix derivation. These are in the IO monad so that they can do things like+ re-run nix-build to recompute hashes, but morally they should just stick to+ editing the derivationFile for their one stated purpose.++ The return contract is:+ - If it makes a modification, it should return a simple message to attach to+ the pull request description to provide context or justification for code+ reviewers (e.g., a GitHub issue or RFC).+ - If it makes no modification, return None+ - If it throws an exception, nixpkgs-update will be aborted for the package and+ no other rewrite functions will run.++ TODO: Setup some unit tests for these!+-}+data Args = Args+ { updateEnv :: Utils.UpdateEnv,+ attrPath :: Text,+ derivationFile :: FilePath,+ derivationContents :: Text,+ hasUpdateScript :: Bool+ }++type Rewriter = (Text -> IO ()) -> Args -> ExceptT Text IO (Maybe Text)++type Plan = [(Text, Rewriter)]++plan :: Plan+plan =+ [ ("version", version),+ ("rustCrateVersion", rustCrateVersion),+ ("golangModuleVersion", golangModuleVersion),+ ("updateScript", updateScript),+ ("", quotedUrlsET) -- Don't change the logger+ --("redirectedUrl", Rewrite.redirectedUrls)+ ]++runAll :: (Text -> IO ()) -> Args -> ExceptT Text IO [Text]+runAll log args = do+ msgs <- forM plan $ \(name, f) -> do+ let log' msg =+ if T.null name+ then log msg+ else log $ ("[" <> name <> "] ") <> msg+ lift $ log' "" -- Print initial empty message to signal start of rewriter+ f log' args+ return $ catMaybes msgs++--------------------------------------------------------------------------------+-- The canonical updater: updates the src attribute and recomputes the sha256+version :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Maybe Text)+version log args@Args {..} = do+ if+ | Nix.numberOfFetchers derivationContents > 1 || Nix.numberOfHashes derivationContents > 1 -> do+ lift $ log "generic version rewriter does not support multiple hashes"+ return Nothing+ | hasUpdateScript -> do+ lift $ log "skipping because derivation has updateScript"+ return Nothing+ | otherwise -> do+ srcVersionFix args+ lift $ log "updated version and sha256"+ return $ Just "Version update"++--------------------------------------------------------------------------------+-- Rewrite meta.homepage (and eventually other URLs) to be quoted if not+-- already, as per https://github.com/NixOS/rfcs/pull/45+quotedUrls ::+ Members '[Process.Process, File.File, Error Text, Output Text] r =>+ Args ->+ Sem r (Maybe Text)+quotedUrls Args {..} = do+ output "[quotedUrls]"+ homepage <- Nix.getHomepage attrPath+ stripped <- case Utils.stripQuotes homepage of+ Nothing -> throw "Could not strip url! This should never happen!"+ Just x -> pure x+ let goodHomepage = "homepage = " <> homepage <> ";"+ let replacer = \target -> File.replace target goodHomepage derivationFile+ urlReplaced1 <- replacer ("homepage = " <> stripped <> ";")+ urlReplaced2 <- replacer ("homepage = " <> stripped <> " ;")+ urlReplaced3 <- replacer ("homepage =" <> stripped <> ";")+ urlReplaced4 <- replacer ("homepage =" <> stripped <> "; ")+ if urlReplaced1 || urlReplaced2 || urlReplaced3 || urlReplaced4+ then do+ output "[quotedUrls]: added quotes to meta.homepage"+ return $ Just "Quoted meta.homepage for [RFC 45](https://github.com/NixOS/rfcs/pull/45)"+ else do+ output "[quotedUrls] nothing found to replace"+ return Nothing++quotedUrlsET :: MonadIO m => (Text -> IO ()) -> Args -> ExceptT Text m (Maybe Text)+quotedUrlsET log rwArgs =+ ExceptT $+ liftIO+ . runFinal+ . embedToFinal+ . Error.runError+ . Process.runIO+ . File.runIO+ . Utils.runLog log+ $ quotedUrls rwArgs++--------------------------------------------------------------------------------+-- Redirect homepage when moved.+redirectedUrls :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Maybe Text)+redirectedUrls log Args {..} = do+ unstripped <- Nix.getHomepageET attrPath+ homepage <- case Utils.stripQuotes unstripped of+ Nothing -> throwE "Could not strip homepage! This should never happen!"+ Just x -> pure x+ response <- liftIO $ do+ manager <- HTTP.newManager HTTP.defaultManagerSettings+ request <- HTTP.parseRequest (T.unpack homepage)+ HTTP.httpLbs request manager+ let status = statusCode $ HTTP.responseStatus response+ if status `elem` [301, 308]+ then do+ lift $ log "Redirecting URL"+ let headers = HTTP.responseHeaders response+ location = lookup "Location" headers+ case location of+ Nothing -> do+ lift $ log "Server did not return a location"+ return Nothing+ Just ((T.decodeUtf8With T.lenientDecode) -> newHomepage) -> do+ _ <- File.replaceIO homepage newHomepage derivationFile+ lift $ log "Replaced homepage"+ return $+ Just $+ "Replaced homepage by "+ <> newHomepage+ <> " due http "+ <> (T.pack . show) status+ else do+ lift $ log "URL not redirected"+ return Nothing++--------------------------------------------------------------------------------+-- Rewrite Rust on rustPlatform.buildRustPackage+-- This is basically `version` above, but with a second pass to also update the+-- cargoSha256 vendor hash.+rustCrateVersion :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Maybe Text)+rustCrateVersion log args@Args {..} = do+ if+ | not (T.isInfixOf "cargoSha256" derivationContents) -> do+ lift $ log "No cargoSha256 found"+ return Nothing+ | hasUpdateScript -> do+ lift $ log "skipping because derivation has updateScript"+ return Nothing+ | otherwise -> do+ -- This starts the same way `version` does, minus the assert+ srcVersionFix args+ -- But then from there we need to do this a second time for the cargoSha256!+ oldCargoSha256 <- Nix.getAttr Nix.Raw "cargoSha256" attrPath+ _ <- lift $ File.replaceIO oldCargoSha256 Nix.sha256Zero derivationFile+ newCargoSha256 <- Nix.getHashFromBuild attrPath+ when (oldCargoSha256 == newCargoSha256) $ throwE "cargoSha256 hashes equal; no update necessary"+ lift . log $ "Replacing cargoSha256 with " <> newCargoSha256+ _ <- lift $ File.replaceIO Nix.sha256Zero newCargoSha256 derivationFile+ -- Ensure the package actually builds and passes its tests+ Nix.build attrPath+ lift $ log "Finished updating Crate version and replacing hashes"+ return $ Just "Rust version update"++--------------------------------------------------------------------------------+-- Rewrite Golang packages with buildGoModule+-- This is basically `version` above, but with a second pass to also update the+-- vendorSha256 go vendor hash.+golangModuleVersion :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Maybe Text)+golangModuleVersion log args@Args {..} = do+ if+ | not (T.isInfixOf "buildGoModule" derivationContents && T.isInfixOf "vendorSha256" derivationContents) -> do+ lift $ log "Not a buildGoModule package with vendorSha256"+ return Nothing+ | hasUpdateScript -> do+ lift $ log "skipping because derivation has updateScript"+ return Nothing+ | otherwise -> do+ -- This starts the same way `version` does, minus the assert+ srcVersionFix args+ -- But then from there we need to do this a second time for the vendorSha256!+ -- Note that explicit `null` cannot be coerced to a string by nix eval --raw+ oldVendorSha256 <- (Nix.getAttr Nix.Raw "vendorSha256" attrPath <|> Nix.getAttr Nix.NoRaw "vendorSha256" attrPath)+ lift . log $ "Found old vendorSha256 = " <> oldVendorSha256+ original <- liftIO $ T.readFile derivationFile+ _ <- lift $ File.replaceIO ("\"" <> oldVendorSha256 <> "\"") "null" derivationFile+ ok <- runExceptT $ Nix.build attrPath+ _ <-+ if isLeft ok+ then do+ _ <- liftIO $ T.writeFile derivationFile original+ _ <- lift $ File.replaceIO oldVendorSha256 Nix.sha256Zero derivationFile+ newVendorSha256 <- Nix.getHashFromBuild attrPath+ _ <- lift $ File.replaceIO Nix.sha256Zero newVendorSha256 derivationFile+ -- Note that on some small bumps, this may not actually change if go.sum did not+ lift . log $ "Replaced vendorSha256 with " <> newVendorSha256+ else do+ lift . log $ "Set vendorSha256 to null"+ -- Ensure the package actually builds and passes its tests+ Nix.build attrPath+ lift $ log "Finished updating vendorSha256"+ return $ Just "Golang update"++--------------------------------------------------------------------------------+-- Calls passthru.updateScript+updateScript :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Maybe Text)+updateScript log Args {..} = do+ if hasUpdateScript+ then do+ (exitCode, msg) <- Nix.runUpdateScript attrPath+ case exitCode of+ ExitSuccess -> do+ lift $ log "Success"+ lift $ log msg+ return $ Just "Ran passthru.UpdateScript"+ ExitFailure num -> do+ throwE $ "[updateScript] Failed with exit code " <> tshow num <> "\n" <> msg+ else do+ lift $ log "skipping because derivation has no updateScript"+ return Nothing+--------------------------------------------------------------------------------+-- Common helper functions and utilities+-- Helper to update version and src attributes, re-computing the sha256.+-- This is done by the generic version upgrader, but is also a sub-component of some of the others.+srcVersionFix :: MonadIO m => Args -> ExceptT Text m ()+srcVersionFix Args {..} = do+ let UpdateEnv {..} = updateEnv+ oldHash <- Nix.getOldHash attrPath+ _ <- lift $ File.replaceIO oldVersion newVersion derivationFile+ _ <- lift $ File.replaceIO oldHash Nix.sha256Zero derivationFile+ newHash <- Nix.getHashFromBuild attrPath+ when (oldHash == newHash) $ throwE "Hashes equal; no update necessary"+ _ <- lift $ File.replaceIO Nix.sha256Zero newHash derivationFile+ return ()
+ src/Skiplist.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Skiplist+ ( packageName,+ content,+ attrPath,+ checkResult,+ python,+ )+where++import Data.Foldable (find)+import qualified Data.Text as T+import OurPrelude++type Skiplist = [(Text -> Bool, Text)]++type TextSkiplister m =+ (MonadError Text m) =>+ Text ->+ m ()++attrPath :: TextSkiplister m+attrPath = skiplister attrPathList++packageName :: TextSkiplister m+packageName name =+ if name == "elementary-xfce-icon-theme" -- https://github.com/ryantm/nixpkgs-update/issues/63+ then return ()+ else skiplister nameList name++content :: TextSkiplister m+content = skiplister contentList++checkResult :: TextSkiplister m+checkResult = skiplister checkResultList++attrPathList :: Skiplist+attrPathList =+ [ prefix+ "lua"+ "Packages for lua are currently skipped. https://github.com/NixOS/nixpkgs/pull/37501#issuecomment-375169646",+ prefix "lxqt" "Packages for lxqt are currently skipped.",+ prefix+ "altcoins.bitcoin"+ "@roconnor asked for a skip on this until something can be done with GPG signatures https://github.com/NixOS/nixpkgs/commit/77f3ac7b7638b33ab198330eaabbd6e0a2e751a9",+ eq "sqlite-interactive" "it is an override",+ eq "harfbuzzFull" "it is an override",+ prefix+ "mate"+ "mate packages are upgraded in lockstep https://github.com/NixOS/nixpkgs/pull/50695#issuecomment-441338593",+ prefix+ "deepin"+ "deepin packages are upgraded in lockstep https://github.com/NixOS/nixpkgs/pull/52327#issuecomment-447684194",+ prefix+ "element-desktop"+ "@Ma27 asked to skip",+ prefix+ "element-web"+ "has to be updated along with element-desktop",+ prefix+ "keybinder"+ "it has weird tags. see nixpkgs-update#232"+ ]++nameList :: Skiplist+nameList =+ [ prefix "r-" "we don't know how to find the attrpath for these",+ infixOf "jquery" "this isn't a real package",+ infixOf "google-cloud-sdk" "complicated package",+ infixOf "github-release" "complicated package",+ infixOf+ "libxc"+ "currently people don't want to update this https://github.com/NixOS/nixpkgs/pull/35821",+ infixOf "perl" "currently don't know how to update perl",+ infixOf "cdrtools" "We keep downgrading this by accident.",+ infixOf "gst" "gstreamer plugins are kept in lockstep.",+ infixOf "electron" "multi-platform srcs in file.",+ infixOf+ "linux-headers"+ "Not updated until many packages depend on it (part of stdenv).",+ infixOf "xfce" "@volth asked to not update xfce",+ infixOf "cmake-cursesUI-qt4UI" "Derivation file is complicated",+ infixOf "iana-etc" "@mic92 takes care of this package",+ infixOf+ "checkbashism"+ "needs to be fixed, see https://github.com/NixOS/nixpkgs/pull/39552",+ eq "isl" "multi-version long building package",+ infixOf "qscintilla" "https://github.com/ryantm/nixpkgs-update/issues/51",+ eq "itstool" "https://github.com/NixOS/nixpkgs/pull/41339",+ infixOf+ "virtualbox"+ "nixpkgs-update cannot handle updating the guest additions https://github.com/NixOS/nixpkgs/pull/42934",+ eq+ "avr-binutils"+ "https://github.com/NixOS/nixpkgs/pull/43787#issuecomment-408649537",+ eq+ "iasl"+ "two updates had to be reverted, https://github.com/NixOS/nixpkgs/pull/46272",+ eq+ "meson"+ "https://github.com/NixOS/nixpkgs/pull/47024#issuecomment-423300633",+ eq+ "burp"+ "skipped until better versioning schema https://github.com/NixOS/nixpkgs/pull/46298#issuecomment-419536301",+ eq "chromedriver" "complicated package",+ eq+ "gitlab-shell"+ "@globin asked to skip in https://github.com/NixOS/nixpkgs/pull/52294#issuecomment-447653417",+ eq+ "gitlab-workhorse"+ "@globin asked to skip in https://github.com/NixOS/nixpkgs/pull/52286#issuecomment-447653409",+ eq "reposurgeon" "takes way too long to build",+ eq "kodelife" "multiple system hashes need to be updated at once",+ eq "openbazaar" "multiple system hashes need to be updated at once",+ eq "eaglemode" "build hangs or takes way too long",+ eq "autoconf" "@prusnak asked to skip",+ eq "abseil-cpp" "@andersk asked to skip"+ ]++contentList :: Skiplist+contentList =+ [ infixOf "nixpkgs-update: no auto update" "Derivation file opts-out of auto-updates",+ infixOf "DO NOT EDIT" "Derivation file says not to edit it",+ infixOf "Do not edit!" "Derivation file says not to edit it",+ -- Skip packages that have special builders+ infixOf "buildRustCrate" "Derivation contains buildRustCrate",+ infixOf "buildRubyGem" "Derivation contains buildRubyGem",+ infixOf "bundlerEnv" "Derivation contains bundlerEnv",+ infixOf "buildPerlPackage" "Derivation contains buildPerlPackage",+ -- Specific skips for classes of packages+ infixOf "goDeps" "Derivation contains goDeps attribute",+ infixOf "https://downloads.haskell.org/ghc/" "GHC packages are versioned per file",+ infixOf "pantheon" "Do not update Pantheon during a release cycle"+ ]++checkResultList :: Skiplist+checkResultList =+ [ infixOf+ "busybox"+ "- busybox result is not automatically checked, because some binaries kill the shell",+ infixOf+ "fcitx"+ "- fcitx result is not automatically checked, because some binaries gets stuck in daemons",+ infixOf+ "x2goclient"+ "- x2goclient result is not automatically checked, because some binaries don't timeout properly",+ infixOf+ "kicad"+ "- kicad result is not automatically checked, because some binaries don't timeout properly",+ infixOf+ "gjs"+ "- gjs result is not automatically checked, because some tests take a long time to run",+ infixOf+ "casperjs"+ "- casperjs result is not automatically checked, because some tests take a long time to run"+ ]++skiplister :: Skiplist -> TextSkiplister m+skiplister skiplist input = forM_ result throwError+ where+ result = snd <$> find (\(isSkiplisted, _) -> isSkiplisted input) skiplist++prefix :: Text -> Text -> (Text -> Bool, Text)+prefix part reason = ((part `T.isPrefixOf`), reason)++infixOf :: Text -> Text -> (Text -> Bool, Text)+infixOf part reason = ((part `T.isInfixOf`), reason)++eq :: Text -> Text -> (Text -> Bool, Text)+eq part reason = ((part ==), reason)++python :: Monad m => Int -> Text -> ExceptT Text m ()+python numPackageRebuilds derivationContents =+ tryAssert+ ( "Python package with too many package rebuilds "+ <> (T.pack . show) numPackageRebuilds+ <> " > "+ <> tshow maxPackageRebuild+ )+ (not isPython || numPackageRebuilds <= maxPackageRebuild)+ where+ isPython = "buildPythonPackage" `T.isInfixOf` derivationContents+ maxPackageRebuild = 25
+ src/Time.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-}++module Time where++import qualified Data.Text as T+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)+import Data.Time.Format (defaultTimeLocale, formatTime, iso8601DateFormat)+import OurPrelude++data Time m a where+ Now :: Time m UTCTime++makeSem ''Time++runIO :: Member (Embed IO) r => Sem (Time ': r) a -> Sem r a+runIO =+ interpret $ \case+ Now -> embed getCurrentTime++runPure :: UTCTime -> Sem (Time ': r) a -> Sem r a+runPure t =+ interpret $ \case+ Now -> pure t++-- | Return the UTC time 1 hour ago++-- $setup+-- >>> import Data.Time.Format (parseTimeOrError)+-- >>> let exampleCurrentTime = parseTimeOrError False defaultTimeLocale "%Y-%-m-%-d" "2019-06-06" :: UTCTime+--+-- Examples:+--+-- >>> run $ runPure exampleCurrentTime oneHourAgo+-- 2019-06-05 23:00:00 UTC++oneHourAgo :: Member Time r => Sem r UTCTime+oneHourAgo = now <&> addUTCTime (fromInteger $ -60 * 60)++-- | Return the UTC time 2 hours ago+--+-- Examples:+--+-- >>> run $ runPure exampleCurrentTime twoHoursAgo+-- 2019-06-05 22:00:00 UTC+twoHoursAgo :: Member Time r => Sem r UTCTime+twoHoursAgo = now <&> addUTCTime (fromInteger $ -60 * 60 * 2)++-- | Return the current ISO8601 date and time without timezone+--+-- TODO: switch to Data.Time.Format.ISO8601 once time-1.9.0 is available+-- unix depends on an earlier version currently https://github.com/haskell/unix/issues/131+--+-- Examples:+--+-- >>> run $ runPure exampleCurrentTime runDate+-- "2019-06-06T00:00:00"+runDate :: Member Time r => Sem r Text+runDate =+ now <&> formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))+ <&> T.pack
src/Update.hs view
@@ -1,248 +1,395 @@ {-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Update- ( updateAll- ) where+ ( addPatched,+ assertNotUpdatedOn,+ cveAll,+ cveReport,+ prMessage,+ sourceGithubAll,+ updateAll,+ updatePackage,+ )+where -import qualified Blacklist+import CVE (CVE, cveID, cveLI) import qualified Check-import Clean (fixSrcUrl)-import Control.Category ((>>>))-import Control.Error-import Control.Exception (SomeException, throw, toException)-import Control.Monad (forM_)-import Data.Function ((&))-import Data.Maybe (fromMaybe)-import Data.Semigroup ((<>))-import Data.Text (Text)+import Control.Concurrent+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.IORef+import Data.Maybe (fromJust)+import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.IO as T-import Data.Time.Clock (getCurrentTime)-import Data.Time.Format (defaultTimeLocale, formatTime, iso8601DateFormat)-import qualified File+import Data.Time.Calendar (showGregorian)+import Data.Time.Clock (UTCTime, getCurrentTime, utctDay) import qualified GH import qualified Git-import NeatInterpolation (text)+import Language.Haskell.TH.Env (envQ)+import NVD (getCVEs, withVulnDB) import qualified Nix-import Prelude hiding (FilePath)-import Shelly+import qualified NixpkgsReview+import OurPrelude+import Outpaths+import qualified Rewrite+import qualified Skiplist+import qualified Time import Utils- ( ExitCode(..)- , Options(..)- , UpdateEnv(..)- , Version- , branchName- , canFail- , checkAttrPathVersion- , eitherToError- , orElse- , ourShell- , parseUpdates- , rewriteError- , setupNixpkgs- , shE- , tRead+ ( Options (..),+ URL,+ UpdateEnv (..),+ Version,+ branchName,+ logDir,+ parseUpdates,+ prTitle,+ whenBatch, )+import qualified Version+import Prelude hiding (log) default (T.Text) -errorExit' :: (Text -> Sh ()) -> Text -> Text -> Sh a-errorExit' log branchName message = do- Git.cleanup branchName- log message- throw (ExitCode 1)+data MergeBaseOutpathsInfo = MergeBaseOutpathsInfo+ { lastUpdated :: UTCTime,+ mergeBaseOutpaths :: Set ResultLine+ } -log' logFile msg- -- TODO: switch to Data.Time.Format.ISO8601 once time-1.9.0 is available- = do- runDate <-- T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) <$>- liftIO getCurrentTime- appendfile logFile (runDate <> " " <> msg <> "\n")+log' :: MonadIO m => FilePath -> Text -> m ()+log' logFile msg = do+ runDate <- liftIO $ runM $ Time.runIO Time.runDate+ liftIO $ T.appendFile logFile (runDate <> " " <> msg <> "\n") -updateAll :: Options -> IO ()-updateAll options =- ourShell options $ do- let logFile = fromText (workingDir options) </> "ups.log"- mkdir_p (fromText (workingDir options))- touchfile logFile- updates <- readfile "packages-to-update.txt"- let log = log' logFile- appendfile logFile "\n\n"- log "New run of ups.sh"- updateLoop options log (parseUpdates updates)+logFileName :: IO String+logFileName = do+ lDir <- logDir+ now <- getCurrentTime+ let logFile = lDir <> "/" <> showGregorian (utctDay now) <> ".log"+ putStrLn ("Using log file: " <> logFile)+ return logFile +getLog :: Options -> IO (Text -> IO ())+getLog o = do+ if batchUpdate o+ then do+ logFile <- logFileName+ let log = log' logFile+ T.appendFile logFile "\n\n"+ return log+ else return T.putStrLn++notifyOptions :: (Text -> IO ()) -> Options -> IO ()+notifyOptions log o = do+ let repr f = if f o then "YES" else "NO"+ let ghUser = GH.untagName . githubUser $ o+ let pr = repr doPR+ let outpaths = repr calculateOutpaths+ let cve = repr makeCVEReport+ let review = repr runNixpkgsReview+ npDir <- tshow <$> Git.nixpkgsDir+ log $+ [interpolate|+ Configured Nixpkgs-Update Options:+ ----------------------------------+ GitHub User: $ghUser+ Send pull request on success: $pr+ Calculate Outpaths: $outpaths+ CVE Security Report: $cve+ Run nixpkgs-review: $review+ Nixpkgs Dir: $npDir+ ----------------------------------|]++updateAll :: Options -> Text -> IO ()+updateAll o updates = do+ log <- getLog o+ log "New run of nixpkgs-update"+ notifyOptions log o+ twoHoursAgo <- runM $ Time.runIO Time.twoHoursAgo+ mergeBaseOutpathSet <-+ liftIO $ newIORef (MergeBaseOutpathsInfo twoHoursAgo S.empty)+ updateLoop o log (parseUpdates updates) mergeBaseOutpathSet++cveAll :: Options -> Text -> IO ()+cveAll o updates = do+ let u' = rights $ parseUpdates updates+ results <-+ mapM+ ( \(p, oldV, newV, url) -> do+ r <- cveReport (UpdateEnv p oldV newV url o)+ return $ p <> ": " <> oldV <> " -> " <> newV <> "\n" <> r+ )+ u'+ T.putStrLn (T.unlines results)++sourceGithubAll :: Options -> Text -> IO ()+sourceGithubAll o updates = do+ let u' = rights $ parseUpdates updates+ _ <-+ runExceptT $ do+ Git.fetchIfStale <|> liftIO (T.putStrLn "Failed to fetch.")+ Git.cleanAndResetTo "master"+ mapM_+ ( \(p, oldV, newV, url) -> do+ let updateEnv = UpdateEnv p oldV newV url o+ runExceptT $ do+ attrPath <- Nix.lookupAttrPath updateEnv+ srcUrl <- Nix.getSrcUrl attrPath+ v <- GH.latestVersion updateEnv srcUrl+ if v /= newV+ then+ liftIO $+ T.putStrLn $+ p <> ": " <> oldV <> " -> " <> newV <> " -> " <> v+ else return ()+ )+ u'+ updateLoop ::- Options- -> (Text -> Sh ())- -> [Either Text (Text, Version, Version)]- -> Sh ()-updateLoop _ log [] = log "ups.sh finished"-updateLoop options log (Left e:moreUpdates) = do+ Options ->+ (Text -> IO ()) ->+ [Either Text (Text, Version, Version, Maybe URL)] ->+ IORef MergeBaseOutpathsInfo ->+ IO ()+updateLoop _ log [] _ = log "nixpkgs-update finished"+updateLoop o log (Left e : moreUpdates) mergeBaseOutpathsContext = do log e- updateLoop options log moreUpdates-updateLoop options log (Right (package, oldVersion, newVersion):moreUpdates) = do- log (package <> " " <> oldVersion <> " -> " <> newVersion)- updated <-- catch_sh- (updatePackage log (UpdateEnv package oldVersion newVersion options))- (\case- ExitCode 0 -> return True- ExitCode _ -> return False)- if updated- then do+ updateLoop o log moreUpdates mergeBaseOutpathsContext+updateLoop o log (Right (pName, oldVer, newVer, url) : moreUpdates) mergeBaseOutpathsContext = do+ log (pName <> " " <> oldVer <> " -> " <> newVer <> fromMaybe "" (fmap (" " <>) url))+ let updateEnv = UpdateEnv pName oldVer newVer url o+ updated <- updatePackageBatch log updateEnv mergeBaseOutpathsContext+ case updated of+ Left failure -> do+ log $ "FAIL " <> failure+ cleanupResult <- runExceptT $ Git.cleanup (branchName updateEnv)+ case cleanupResult of+ Left e -> liftIO $ print e+ _ ->+ if ".0" `T.isSuffixOf` newVer+ then+ let Just newNewVersion = ".0" `T.stripSuffix` newVer+ in updateLoop+ o+ log+ (Right (pName, oldVer, newNewVersion, url) : moreUpdates)+ mergeBaseOutpathsContext+ else updateLoop o log moreUpdates mergeBaseOutpathsContext+ Right _ -> do log "SUCCESS"- updateLoop options log moreUpdates- else do- log "FAIL"- if ".0" `T.isSuffixOf` newVersion- then let Just newNewVersion = ".0" `T.stripSuffix` newVersion- in updateLoop- options- log- (Right (package, oldVersion, newNewVersion) : moreUpdates)- else updateLoop options log moreUpdates+ updateLoop o log moreUpdates mergeBaseOutpathsContext -updatePackage :: (Text -> Sh ()) -> UpdateEnv -> Sh Bool-updatePackage log updateEnv = do- let errorExit = errorExit' log (branchName updateEnv)- eitherToError errorExit (pure (Blacklist.packageName (packageName updateEnv)))- setupNixpkgs- -- Check whether requested version is newer than the current one- eitherToError errorExit (Nix.compareVersions updateEnv)- -- Check whether package name is on blacklist- Git.fetchIfStale- whenM- (Git.autoUpdateBranchExists (packageName updateEnv))- (errorExit "Update branch already on origin.")- Git.cleanAndResetToMaster- attrPath <- eitherToError errorExit (Nix.lookupAttrPath updateEnv)- srcUrls <- eitherToError errorExit (Nix.getSrcUrls attrPath)- eitherToError errorExit (pure (Blacklist.srcUrl srcUrls))- eitherToError errorExit (pure (Blacklist.attrPath attrPath))- derivationFile <-- eitherToError errorExit (Nix.getDerivationFile updateEnv attrPath)- flip- catches_sh- [ ShellyHandler (\(ex :: ExitCode) -> throw ex)- , ShellyHandler (\(ex :: SomeException) -> errorExit (T.pack (show ex)))- ] $ do- unless (checkAttrPathVersion attrPath (newVersion updateEnv)) $- errorExit- ("Version in attr path " <> attrPath <> " not compatible with " <>- newVersion updateEnv)- -- Make sure it hasn't been updated on master- masterDerivationContents <- readfile derivationFile- eitherToError- errorExit- (Nix.oldVersionOn updateEnv "master" masterDerivationContents)- -- Make sure it hasn't been updated on staging- Git.cleanAndResetToStaging- stagingDerivationContents <- readfile derivationFile- eitherToError- errorExit- (Nix.oldVersionOn updateEnv "staging" stagingDerivationContents)- Git.checkoutAtMergeBase (branchName updateEnv)- derivationContents <- readfile derivationFile- unless (Nix.numberOfFetchers derivationContents <= 1) $- errorExit $ "More than one fetcher in " <> toTextIgnore derivationFile- eitherToError errorExit (pure (Blacklist.content derivationContents))- oldHash <- eitherToError errorExit (Nix.getOldHash attrPath)- oldSrcUrl <- eitherToError errorExit (Nix.getSrcUrl attrPath)- File.replace (oldVersion updateEnv) (newVersion updateEnv) derivationFile- newSrcUrl <- eitherToError errorExit (Nix.getSrcUrl attrPath)- when (oldSrcUrl == newSrcUrl) $ errorExit "Source url did not change."- newHash <-- canFail (T.strip <$> cmd "nix-prefetch-url" "-A" (attrPath <> ".src")) `orElse`- fixSrcUrl updateEnv derivationFile attrPath oldSrcUrl `orElse`- errorExit "Could not prefetch new version URL."- when (oldHash == newHash) $ errorExit "Hashes equal; no update necessary"- File.replace oldHash newHash derivationFile- eitherToError errorExit (Nix.build attrPath)- result <-- fromText <$>- (T.strip <$>- (cmd "readlink" "./result" `orElse` cmd "readlink" "./result-bin")) `orElse`- errorExit "Could not find result link."- publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result+-- Arguments this function should have to make it testable:+-- - the merge base commit (should be updated externally to this function)+-- - the merge base context should be updated externally to this function+-- - the commit for branches: master, staging, staging-next+updatePackageBatch ::+ (Text -> IO ()) ->+ UpdateEnv ->+ IORef MergeBaseOutpathsInfo ->+ IO (Either Text ())+updatePackageBatch log updateEnv@UpdateEnv {..} mergeBaseOutpathsContext =+ runExceptT $ do+ let pr = doPR options + -- Filters that don't need git+ whenBatch updateEnv do+ Skiplist.packageName packageName+ -- Update our git checkout+ Git.fetchIfStale <|> liftIO (T.putStrLn "Failed to fetch.")+ Git.cleanAndResetTo "master"++ -- Filters: various cases where we shouldn't update the package+ attrPath <- Nix.lookupAttrPath updateEnv+ hasUpdateScript <- Nix.hasUpdateScript attrPath++ whenBatch updateEnv do+ Skiplist.attrPath attrPath+ when pr do+ Git.checkAutoUpdateBranchDoesntExist packageName+ GH.checkExistingUpdatePR updateEnv attrPath++ unless hasUpdateScript do+ Nix.assertNewerVersion updateEnv+ Version.assertCompatibleWithPathPin updateEnv attrPath++ derivationFile <- Nix.getDerivationFile attrPath+ unless hasUpdateScript do+ assertNotUpdatedOn updateEnv derivationFile "master"+ assertNotUpdatedOn updateEnv derivationFile "staging"+ assertNotUpdatedOn updateEnv derivationFile "staging-next"++ -- Calculate output paths for rebuilds and our merge base+ mergeBase <- if batchUpdate options+ then Git.checkoutAtMergeBase (branchName updateEnv)+ else pure "HEAD"+ let calcOutpaths = calculateOutpaths options+ oneHourAgo <- liftIO $ runM $ Time.runIO Time.oneHourAgo+ mergeBaseOutpathsInfo <- liftIO $ readIORef mergeBaseOutpathsContext+ mergeBaseOutpathSet <-+ if calcOutpaths && lastUpdated mergeBaseOutpathsInfo < oneHourAgo+ then do+ mbos <- currentOutpathSet+ now <- liftIO getCurrentTime+ liftIO $+ writeIORef mergeBaseOutpathsContext (MergeBaseOutpathsInfo now mbos)+ return mbos+ else+ if calcOutpaths+ then return $ mergeBaseOutpaths mergeBaseOutpathsInfo+ else return $ dummyOutpathSetBefore attrPath++ -- Get the original values for diffing purposes+ derivationContents <- liftIO $ T.readFile derivationFile+ oldHash <- Nix.getOldHash attrPath+ oldSrcUrl <- Nix.getSrcUrl attrPath+ oldVerMay <- rightMay `fmapRT` (lift $ runExceptT $ Nix.getAttr Nix.Raw "version" attrPath)++ tryAssert+ "The derivation has no 'version' attribute, so do not know how to figure out the version while doing an updateScript update"+ (not hasUpdateScript || isJust oldVerMay)++ -- One final filter+ Skiplist.content derivationContents++ ----------------------------------------------------------------------------+ -- UPDATES+ --+ -- At this point, we've stashed the old derivation contents and+ -- validated that we actually should be rewriting something. Get+ -- to work processing the various rewrite functions!+ rewriteMsgs <- Rewrite.runAll log Rewrite.Args {..}+ ----------------------------------------------------------------------------++ -- Compute the diff and get updated values+ diffAfterRewrites <- Git.diff mergeBase+ tryAssert+ "The diff was empty after rewrites."+ (diffAfterRewrites /= T.empty)+ lift . log $ "Diff after rewrites:\n" <> diffAfterRewrites+ updatedDerivationContents <- liftIO $ T.readFile derivationFile+ newSrcUrl <- Nix.getSrcUrl attrPath+ newHash <- Nix.getHash attrPath+ newVerMay <- rightMay `fmapRT` (lift $ runExceptT $ Nix.getAttr Nix.Raw "version" attrPath)++ tryAssert+ "The derivation has no 'version' attribute, so do not know how to figure out the version while doing an updateScript update"+ (not hasUpdateScript || isJust newVerMay)++ -- Sanity checks to make sure the PR is worth opening+ unless hasUpdateScript do+ when (derivationContents == updatedDerivationContents) $ throwE "No rewrites performed on derivation."+ when (oldSrcUrl == newSrcUrl) $ throwE "Source url did not change. "+ when (oldHash == newHash) $ throwE "Hashes equal; no update necessary"+ editedOutpathSet <- if calcOutpaths then currentOutpathSet else return $ dummyOutpathSetAfter attrPath+ let opDiff = S.difference mergeBaseOutpathSet editedOutpathSet+ let numPRebuilds = numPackageRebuilds opDiff+ whenBatch updateEnv do+ Skiplist.python numPRebuilds derivationContents+ when (numPRebuilds == 0) (throwE "Update edits cause no rebuilds.")+ Nix.build attrPath+ --+ -- Update updateEnv if using updateScript+ updateEnv' <-+ if hasUpdateScript+ then do+ -- Already checked that these are Just above.+ let Just oldVer = oldVerMay+ let Just newVer = newVerMay+ return $+ UpdateEnv+ packageName+ oldVer+ newVer+ (Just "passthru.updateScript")+ options+ else return updateEnv++ --+ -- Publish the result+ lift . log $ "Successfully finished processing"+ result <- Nix.resultLink+ publishPackage log updateEnv' oldSrcUrl newSrcUrl attrPath result (Just opDiff) rewriteMsgs+ whenBatch updateEnv do+ Git.cleanAndResetTo "master"+ publishPackage ::- (Text -> Sh ()) -> UpdateEnv -> Text -> Text -> Text -> FilePath -> Sh Bool-publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result = do- let errorExit = errorExit' log (branchName updateEnv)- log ("cachix " <> (T.pack . show) result)- Nix.cachix result+ (Text -> IO ()) ->+ UpdateEnv ->+ Text ->+ Text ->+ Text ->+ Text ->+ Maybe (Set ResultLine) ->+ [Text] ->+ ExceptT Text IO ()+publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result opDiff rewriteMsgs = do+ let prBase =+ if (isNothing opDiff || numPackageRebuilds (fromJust opDiff) < 100)+ then "master"+ else "staging"+ cachixTestInstructions <- doCachix log updateEnv result resultCheckReport <-- case Blacklist.checkResult (packageName updateEnv) of- Right () -> sub (Check.result updateEnv result)+ case Skiplist.checkResult (packageName updateEnv) of+ Right () -> lift $ Check.result updateEnv (T.unpack result) Left msg -> pure msg- d <- eitherToError errorExit (Nix.getDescription attrPath)- let metaDescription =- "\n\nmeta.description for " <> attrPath <> " is: '" <> d <> "'."- releaseUrlResult <- liftIO $ GH.releaseUrl newSrcUrl- releaseUrlMessage <-- case releaseUrlResult of- Left e -> do- log e- return ""- Right msg -> return ("\n[Release on GitHub](" <> msg <> ")\n\n")- compareUrlResult <- liftIO $ GH.compareUrl oldSrcUrl newSrcUrl- compareUrlMessage <-- case compareUrlResult of- Left e -> do- log e- return "\n"- Right msg -> return ("\n[Compare changes on GitHub](" <> msg <> ")\n\n")- maintainers <- eitherToError errorExit (Nix.getMaintainers attrPath)- let maintainersCc =- if not (T.null maintainers)- then "\n\ncc " <> maintainers <> " for testing."- else ""+ metaDescription <- Nix.getDescription attrPath <|> return T.empty+ metaHomepage <- Nix.getHomepageET attrPath <|> return T.empty+ metaChangelog <- Nix.getChangelog attrPath <|> return T.empty+ cveRep <- liftIO $ cveReport updateEnv+ releaseUrl <- GH.releaseUrl updateEnv newSrcUrl <|> return ""+ compareUrl <- GH.compareUrl oldSrcUrl newSrcUrl <|> return ""+ maintainers <- Nix.getMaintainers attrPath let commitMsg = commitMessage updateEnv attrPath Git.commit commitMsg commitHash <- Git.headHash+ nixpkgsReviewMsg <-+ if prBase /= "staging" && (runNixpkgsReview . options $ updateEnv)+ then liftIO $ NixpkgsReview.runReport log commitHash+ else return "" -- Try to push it three times- Git.push updateEnv `orElse` Git.push updateEnv `orElse` Git.push updateEnv- isBroken <- eitherToError errorExit (Nix.getIsBroken attrPath)- untilOfBorgFree- GH.pr- (prMessage- updateEnv- isBroken- metaDescription- releaseUrlMessage- compareUrlMessage- resultCheckReport- commitHash- attrPath- maintainersCc- result)- Git.cleanAndResetToMaster- return True--repologyUrl :: UpdateEnv -> Text-repologyUrl updateEnv = [text|https://repology.org/metapackage/$pname/versions|]- where- pname = (packageName >>> T.toLower) updateEnv+ when+ (doPR . options $ updateEnv)+ (Git.push updateEnv <|> Git.push updateEnv <|> Git.push updateEnv)+ isBroken <- Nix.getIsBroken attrPath+ when+ (batchUpdate . options $ updateEnv)+ (lift untilOfBorgFree)+ let prMsg =+ prMessage+ updateEnv+ isBroken+ metaDescription+ metaHomepage+ metaChangelog+ rewriteMsgs+ releaseUrl+ compareUrl+ resultCheckReport+ commitHash+ attrPath+ maintainers+ result+ (fromMaybe "" (outpathReport <$> opDiff))+ cveRep+ cachixTestInstructions+ nixpkgsReviewMsg+ liftIO $ log prMsg+ if (doPR . options $ updateEnv)+ then do+ let ghUser = GH.untagName . githubUser . options $ updateEnv+ pullRequestUrl <- GH.pr updateEnv (prTitle updateEnv attrPath) prMsg (ghUser <> ":" <> (branchName updateEnv)) prBase+ liftIO $ log pullRequestUrl+ else liftIO $ T.putStrLn prMsg commitMessage :: UpdateEnv -> Text -> Text-commitMessage updateEnv attrPath =- let oV = oldVersion updateEnv- nV = newVersion updateEnv- repologyLink = repologyUrl updateEnv- in [text|- $attrPath: $oV -> $nV-- Semi-automatic update generated by- https://github.com/ryantm/nixpkgs-update tools. This update was made- based on information from- $repologyLink- |]+commitMessage updateEnv attrPath = prTitle updateEnv attrPath brokenWarning :: Bool -> Text brokenWarning False = ""@@ -250,80 +397,280 @@ "- WARNING: Package has meta.broken=true; Please manually test this package update and remove the broken attribute." prMessage ::- UpdateEnv- -> Bool- -> Text- -> Text- -> Text- -> Text- -> Text- -> Text- -> Text- -> FilePath- -> Text-prMessage updateEnv isBroken metaDescription releaseUrlMessage compareUrlMessage resultCheckReport commitHash attrPath maintainersCc resultPath =+ UpdateEnv ->+ Bool ->+ Text ->+ Text ->+ Text ->+ [Text] ->+ Text ->+ Text ->+ Text ->+ Text ->+ Text ->+ Text ->+ Text ->+ Text ->+ Text ->+ Text ->+ Text ->+ Text+prMessage updateEnv isBroken metaDescription metaHomepage metaChangelog rewriteMsgs releaseUrl compareUrl resultCheckReport commitHash attrPath maintainers resultPath opReport cveRep cachixTestInstructions nixpkgsReviewMsg =+ -- Some components of the PR description are pre-generated prior to calling+ -- because they require IO, but in general try to put as much as possible for+ -- the formatting into the pure function so that we can control the body+ -- formatting in one place and unit test it. let brokenMsg = brokenWarning isBroken- oV = oldVersion updateEnv- nV = newVersion updateEnv- repologyLink = repologyUrl updateEnv- result = toTextIgnore resultPath- in [text|- $attrPath: $oV -> $nV+ metaHomepageLine =+ if metaHomepage == T.empty+ then ""+ else "meta.homepage for " <> attrPath <> " is: " <> metaHomepage+ metaDescriptionLine =+ if metaDescription == T.empty+ then ""+ else "meta.description for " <> attrPath <> " is: " <> metaDescription+ metaChangelogLine =+ if metaDescription == T.empty+ then ""+ else "meta.changelog for " <> attrPath <> " is: " <> metaChangelog+ rewriteMsgsLine = foldl (\ms m -> ms <> T.pack "\n- " <> m) "\n###### Updates performed" rewriteMsgs+ maintainersCc =+ if not (T.null maintainers)+ then "cc " <> maintainers <> " for [testing](https://github.com/ryantm/nixpkgs-update/blob/master/doc/nixpkgs-maintainer-faq.md#r-ryantm-opened-a-pr-for-my-package-what-do-i-do)."+ else ""+ releaseUrlMessage =+ if releaseUrl == T.empty+ then ""+ else "- [Release on GitHub](" <> releaseUrl <> ")"+ compareUrlMessage =+ if compareUrl == T.empty+ then ""+ else "- [Compare changes on GitHub](" <> compareUrl <> ")"+ nixpkgsReviewSection =+ if nixpkgsReviewMsg == T.empty+ then "NixPkgs review skipped"+ else+ [interpolate|+ We have automatically built all packages that will get rebuilt due to+ this change. - Semi-automatic update generated by https://github.com/ryantm/nixpkgs-update tools. This update was made based on information from $repologyLink.+ This gives evidence on whether the upgrade will break dependent packages.+ Note sometimes packages show up as _failed to build_ independent of the+ change, simply because they are already broken on the target branch.++ $nixpkgsReviewMsg+ |]+ pat link = [interpolate|This update was made based on information from $link.|]+ sourceLinkInfo = maybe "" pat $ sourceURL updateEnv+ ghUser = GH.untagName . githubUser . options $ updateEnv+ batch = batchUpdate . options $ updateEnv+ automatic = if batch then "Automatic" else "Semi-automatic"+ in [interpolate|+ $automatic update generated by [nixpkgs-update](https://github.com/ryantm/nixpkgs-update) tools. $sourceLinkInfo $brokenMsg- $metaDescription++ $metaDescriptionLine++ $metaHomepageLine++ $metaChangelogLine++ $rewriteMsgsLine++ ###### To inspect upstream changes+ $releaseUrlMessage+ $compareUrlMessage++ ###### Impact+ <details> <summary>- Checks done (click to expand)+ <b>Checks done</b> (click to expand) </summary> + ---+ - built on NixOS $resultCheckReport + ---+ </details> <details> <summary>- Instructions to test this update (click to expand)+ <b>Rebuild report</b> (if merged into master) (click to expand) </summary> - Either download from Cachix: ```- nix-store -r $result \- --option binary-caches 'https://cache.nixos.org/ https://r-ryantm.cachix.org/' \- --option trusted-public-keys '- r-ryantm.cachix.org-1:gkUbLkouDAyvBdpBX0JOdIiD2/DP1ldF3Z3Y6Gqcc4c=- cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=- '+ $opReport ```- (r-ryantm's Cachix cache is only trusted for this store-path realization.) - Or, build yourself:+ </details>++ <details>+ <summary>+ <b>Instructions to test this update</b> (click to expand)+ </summary>++ ---++ $cachixTestInstructions ```- nix-build -A $attrPath https://github.com/r-ryantm/nixpkgs/archive/$commitHash.tar.gz+ nix-build -A $attrPath https://github.com/$ghUser/nixpkgs/archive/$commitHash.tar.gz ``` After you've downloaded or built it, look at the files and if there are any, run the binaries: ```- ls -la $result- ls -la $result/bin+ ls -la $resultPath+ ls -la $resultPath/bin ``` + --- </details> <br/>++ $cveRep++ ### Pre-merge build results++ $nixpkgsReviewSection++ ---++ ###### Maintainer pings+ $maintainersCc |] -untilOfBorgFree :: Sh ()+jqBin :: String+jqBin = fromJust ($$(envQ "JQ") :: Maybe String) <> "/bin/jq"++untilOfBorgFree :: MonadIO m => m () untilOfBorgFree = do- waiting :: Int <-- tRead <$>- canFail- (cmd "curl" "-s" "https://events.nix.ci/stats.php" -|-- cmd "jq" ".evaluator.messages.waiting")+ stats <-+ shell "curl -s https://events.nix.ci/stats.php" & readProcessInterleaved_+ waiting <-+ shell (jqBin <> " .evaluator.messages.waiting") & setStdin (byteStringInput stats)+ & readProcessInterleaved_+ & fmap (BSL.readInt >>> fmap fst >>> fromMaybe 0) when (waiting > 2) $ do- sleep 60+ liftIO $ threadDelay 60000000 untilOfBorgFree++assertNotUpdatedOn ::+ MonadIO m => UpdateEnv -> FilePath -> Text -> ExceptT Text m ()+assertNotUpdatedOn updateEnv derivationFile branch = do+ npDir <- liftIO $ Git.nixpkgsDir+ let Just file = T.stripPrefix (T.pack npDir <> "/") (T.pack derivationFile)+ derivationContents <- Git.show branch file+ Nix.assertOldVersionOn updateEnv branch derivationContents++addPatched :: Text -> Set CVE -> IO [(CVE, Bool)]+addPatched attrPath set = do+ let list = S.toList set+ forM+ list+ ( \cve -> do+ patched <- runExceptT $ Nix.hasPatchNamed attrPath (cveID cve)+ let p =+ case patched of+ Left _ -> False+ Right r -> r+ return (cve, p)+ )++cveReport :: UpdateEnv -> IO Text+cveReport updateEnv =+ if not (makeCVEReport . options $ updateEnv)+ then return ""+ else withVulnDB $ \conn -> do+ let pname1 = packageName updateEnv+ let pname2 = T.replace "-" "_" pname1+ oldCVEs1 <- getCVEs conn pname1 (oldVersion updateEnv)+ oldCVEs2 <- getCVEs conn pname2 (oldVersion updateEnv)+ let oldCVEs = S.fromList (oldCVEs1 ++ oldCVEs2)+ newCVEs1 <- getCVEs conn pname1 (newVersion updateEnv)+ newCVEs2 <- getCVEs conn pname2 (newVersion updateEnv)+ let newCVEs = S.fromList (newCVEs1 ++ newCVEs2)+ let inOldButNotNew = S.difference oldCVEs newCVEs+ inNewButNotOld = S.difference newCVEs oldCVEs+ inBoth = S.intersection oldCVEs newCVEs+ ifEmptyNone t =+ if t == T.empty+ then "none"+ else t+ inOldButNotNew' <- addPatched (packageName updateEnv) inOldButNotNew+ inNewButNotOld' <- addPatched (packageName updateEnv) inNewButNotOld+ inBoth' <- addPatched (packageName updateEnv) inBoth+ let toMkdownList = fmap (uncurry cveLI) >>> T.unlines >>> ifEmptyNone+ fixedList = toMkdownList inOldButNotNew'+ newList = toMkdownList inNewButNotOld'+ unresolvedList = toMkdownList inBoth'+ if fixedList == "none" && unresolvedList == "none" && newList == "none"+ then return ""+ else+ return+ [interpolate|+ ###### Security vulnerability report++ <details>+ <summary>+ Security report (click to expand)+ </summary>++ CVEs resolved by this update:+ $fixedList++ CVEs introduced by this update:+ $newList++ CVEs present in both versions:+ $unresolvedList+++ </details>+ <br/>+ |]++doCachix :: MonadIO m => (Text -> m ()) -> UpdateEnv -> Text -> ExceptT Text m Text+doCachix log updateEnv resultPath =+ let o = options updateEnv+ in+ if batchUpdate o && "r-ryantm" == (GH.untagName $ githubUser o)+ then do+ return+ [interpolate|+ Either **download from Cachix**:+ ```+ nix-store -r $resultPath \+ --option binary-caches 'https://cache.nixos.org/ https://nix-community.cachix.org/' \+ --option trusted-public-keys '+ nix-community.cachix.org-1:mB9FSh9qf2dCimDSUo8Zy7bkq5CX+/rkCWyvRCYg3Fs=+ cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=+ '+ ```+ (The Cachix cache is only trusted for this store-path realization.)+ For the Cachix download to work, your user must be in the `trusted-users` list or you can use `sudo` since root is effectively trusted.++ Or, **build yourself**:+ |]+ else do+ lift $ log "skipping cachix"+ return "Build yourself:"++updatePackage ::+ Options ->+ Text ->+ IO (Either Text ())+updatePackage o updateInfo = do+ let (p, oldV, newV, url) = head (rights (parseUpdates updateInfo))+ let updateEnv = UpdateEnv p oldV newV url o+ let log = T.putStrLn+ liftIO $ notifyOptions log o+ twoHoursAgo <- runM $ Time.runIO Time.twoHoursAgo+ mergeBaseOutpathSet <-+ liftIO $ newIORef (MergeBaseOutpathsInfo twoHoursAgo S.empty)+ updatePackageBatch log updateEnv mergeBaseOutpathSet
src/Utils.hs view
@@ -1,182 +1,292 @@ {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Utils- ( Options(..)- , Version- , UpdateEnv(..)- , canFail- , checkAttrPathVersion- , orElse- , setupNixpkgs- , tRead- , parseUpdates- , succeded- , ExitCode(..)- , shE- , rewriteError- , eitherToError- , branchName- , ourShell- ) where+ ( Boundary (..),+ Options (..),+ ProductID,+ URL,+ UpdateEnv (..),+ Version,+ VersionMatcher (..),+ branchName,+ branchPrefix,+ getGithubToken,+ getGithubUser,+ logDir,+ nixBuildOptions,+ nixCommonOptions,+ overwriteErrorT,+ parseUpdates,+ prTitle,+ runLog,+ srcOrMain,+ stripQuotes,+ tRead,+ whenBatch,+ )+where -import Control.Exception (Exception)-import Data.Bifunctor (first)-import Data.Semigroup ((<>))-import Data.Text (Text)+import Data.Bits ((.|.))+import Data.Maybe (fromJust) import qualified Data.Text as T-import Prelude hiding (FilePath)-import Shelly+import qualified Data.Text.IO as T+import Database.SQLite.Simple (ResultError (..), SQLData (..))+import Database.SQLite.Simple.FromField+ ( FieldParser,+ FromField,+ fromField,+ returnError,+ )+import Database.SQLite.Simple.Internal (Field (..))+import Database.SQLite.Simple.Ok (Ok (..))+import Database.SQLite.Simple.ToField (ToField, toField)+import qualified GitHub as GH+import OurPrelude+import Polysemy.Output+import System.Directory (doesDirectoryExist)+import System.Posix.Directory (createDirectory)+import System.Posix.Env (getEnv)+import System.Posix.Files+ ( directoryMode,+ fileExist,+ groupModes,+ otherExecuteMode,+ otherReadMode,+ ownerModes,+ )+import System.Posix.Temp (mkdtemp)+import System.Posix.Types (FileMode)+import Text.Read (readEither)+import Type.Reflection (Typeable) default (T.Text) +type ProductID = Text+ type Version = Text +type URL = Text++-- | The Ord instance is used to sort lists of matchers in order to compare them+-- as a set, it is not useful for comparing bounds since the ordering of bounds+-- depends on whether it is a start or end bound.+data Boundary a+ = Unbounded+ | Including a+ | Excluding a+ deriving (Eq, Ord, Show, Read)++-- | The Ord instance is used to sort lists of matchers in order to compare them+-- as a set, it is not useful for comparing versions.+data VersionMatcher+ = SingleMatcher Version+ | RangeMatcher (Boundary Version) (Boundary Version)+ deriving (Eq, Ord, Show, Read)++readField :: (Read a, Typeable a) => FieldParser a+readField f@(Field (SQLText t) _) =+ case readEither (T.unpack t) of+ Right x -> Ok x+ Left e -> returnError ConversionFailed f $ "read error: " <> e+readField f = returnError ConversionFailed f "expecting SQLText column type"++showField :: Show a => a -> SQLData+showField = toField . show++instance FromField VersionMatcher where+ fromField = readField++instance ToField VersionMatcher where+ toField = showField+ data Options = Options- { dryRun :: Bool- , workingDir :: Text- , githubToken :: Text+ { doPR :: Bool,+ batchUpdate :: Bool,+ githubUser :: GH.Name GH.Owner,+ githubToken :: Text,+ makeCVEReport :: Bool,+ runNixpkgsReview :: Bool,+ calculateOutpaths :: Bool }+ deriving (Show) data UpdateEnv = UpdateEnv- { packageName :: Text- , oldVersion :: Version- , newVersion :: Version- , options :: Options+ { packageName :: Text,+ oldVersion :: Version,+ newVersion :: Version,+ sourceURL :: Maybe URL,+ options :: Options } -setupNixpkgs :: Sh ()-setupNixpkgs = do- home <- get_env_text "HOME"- let nixpkgsPath = home </> ".cache" </> "nixpkgs"- unlessM (test_e nixpkgsPath) $ do- cmd "hub" "clone" "nixpkgs" nixpkgsPath -- requires that user has forked nixpkgs- cd nixpkgsPath- cmd "git" "remote" "add" "upstream" "https://github.com/NixOS/nixpkgs"- cmd "git" "fetch" "upstream"- cd nixpkgsPath- setenv "NIX_PATH" ("nixpkgs=" <> toTextIgnore nixpkgsPath)---- | Set environment variables needed by various programs-setUpEnvironment :: Options -> Sh ()-setUpEnvironment options = do- setenv "PAGER" ""- setenv "GITHUB_TOKEN" (githubToken options)+whenBatch :: Applicative f => UpdateEnv -> f () -> f ()+whenBatch updateEnv = when (batchUpdate . options $ updateEnv) -ourShell :: Options -> Sh a -> IO a-ourShell o s = shelly $ verbosely $ do- setUpEnvironment o- s+prTitle :: UpdateEnv -> Text -> Text+prTitle updateEnv attrPath =+ let oV = oldVersion updateEnv+ nV = newVersion updateEnv+ in T.strip [interpolate| $attrPath: $oV -> $nV |] -shE :: Sh a -> Sh (Either Text a)-shE s = do- r <- canFail s- status <- lastExitCode- case status of- 0 -> return $ Right r- c -> return $ Left ("Exit code: " <> T.pack (show c))+regDirMode :: FileMode+regDirMode =+ directoryMode .|. ownerModes .|. groupModes .|. otherReadMode+ .|. otherExecuteMode -rewriteError :: Text -> Sh (Either Text a) -> Sh (Either Text a)-rewriteError t = fmap (first (const t))+logsDirectory :: MonadIO m => ExceptT Text m FilePath+logsDirectory = do+ dir <-+ noteT "Could not get environment variable LOGS_DIRECTORY" $+ MaybeT $+ liftIO $+ getEnv "LOGS_DIRECTORY"+ dirExists <- liftIO $ doesDirectoryExist dir+ tryAssert ("LOGS_DIRECTORY " <> T.pack dir <> " does not exist.") dirExists+ unless+ dirExists+ ( liftIO $+ putStrLn "creating xdgRuntimeDir" >> createDirectory dir regDirMode+ )+ return dir -eitherToError :: (Text -> Sh a) -> Sh (Either Text a) -> Sh a-eitherToError errorExit s = do- e <- s- either errorExit return e+xdgRuntimeDir :: MonadIO m => ExceptT Text m FilePath+xdgRuntimeDir = do+ xDir <-+ noteT "Could not get environment variable XDG_RUNTIME_DIR" $+ MaybeT $+ liftIO $+ getEnv "XDG_RUNTIME_DIR"+ xDirExists <- liftIO $ doesDirectoryExist xDir+ tryAssert ("XDG_RUNTIME_DIR " <> T.pack xDir <> " does not exist.") xDirExists+ let dir = xDir <> "/nixpkgs-update"+ dirExists <- liftIO $ fileExist dir+ unless+ dirExists+ ( liftIO $+ putStrLn "creating xdgRuntimeDir" >> createDirectory dir regDirMode+ )+ return dir -canFail :: Sh a -> Sh a-canFail = errExit False+tmpRuntimeDir :: MonadIO m => ExceptT Text m FilePath+tmpRuntimeDir = do+ dir <- liftIO $ mkdtemp "nixpkgs-update"+ dirExists <- liftIO $ doesDirectoryExist dir+ tryAssert+ ("Temporary directory " <> T.pack dir <> " does not exist.")+ dirExists+ return dir -succeded :: Sh a -> Sh Bool-succeded s = do- canFail s- status <- lastExitCode- return (status == 0)+logDir :: IO FilePath+logDir = do+ r <-+ runExceptT+ ( logsDirectory <|> xdgRuntimeDir <|> tmpRuntimeDir+ <|> throwE+ "Failed to create log directory."+ )+ case r of+ Right dir -> return dir+ Left e -> error $ T.unpack e -orElse :: Sh a -> Sh a -> Sh a-orElse a b = do- v <- canFail a- status <- lastExitCode- if status == 0- then return v- else b+overwriteErrorT :: MonadIO m => Text -> ExceptT Text m a -> ExceptT Text m a+overwriteErrorT t = fmapLT (const t) -infixl 3 `orElse`+branchPrefix :: Text+branchPrefix = "auto-update/" branchName :: UpdateEnv -> Text-branchName ue = "auto-update/" <> packageName ue+branchName ue = branchPrefix <> packageName ue -parseUpdates :: Text -> [Either Text (Text, Version, Version)]+parseUpdates :: Text -> [Either Text (Text, Version, Version, Maybe URL)] parseUpdates = map (toTriple . T.words) . T.lines where- toTriple :: [Text] -> Either Text (Text, Version, Version)- toTriple [package, oldVersion, newVersion] =- Right (package, oldVersion, newVersion)+ toTriple :: [Text] -> Either Text (Text, Version, Version, Maybe URL)+ toTriple [package, oldVer, newVer] = Right (package, oldVer, newVer, Nothing)+ toTriple [package, oldVer, newVer, url] = Right (package, oldVer, newVer, Just url) toTriple line = Left $ "Unable to parse update: " <> T.unwords line tRead :: Read a => Text -> a tRead = read . T.unpack -notElemOf :: (Eq a, Foldable t) => t a -> a -> Bool-notElemOf options = not . flip elem options+srcOrMain :: MonadIO m => (Text -> ExceptT Text m a) -> Text -> ExceptT Text m a+srcOrMain et attrPath = et (attrPath <> ".src") <|> et attrPath --- | Similar to @breakOn@, but will not keep the pattern at the beginning of the suffix.------ Examples:------ > breakOn "::" "a::b::c"--- ("a","b::c")-clearBreakOn :: Text -> Text -> (Text, Text)-clearBreakOn boundary string =- let (prefix, suffix) = T.breakOn boundary string- in if T.null suffix- then (prefix, suffix)- else (prefix, T.drop (T.length boundary) suffix)+nixCommonOptions :: [String]+nixCommonOptions =+ [ "--arg",+ "config",+ "{ allowBroken = true; allowUnfree = true; allowAliases = false; }",+ "--arg",+ "overlays",+ "[ ]"+ ] --- | Check if attribute path is not pinned to a certain version.--- If a derivation is expected to stay at certain version branch,--- it will usually have the branch as a part of the attribute path.------ Examples:------ >>> checkAttrPathVersion "libgit2_0_25" "0.25.3"--- True------ >>> checkAttrPathVersion "owncloud90" "9.0.3"--- True------ >>> checkAttrPathVersion "owncloud-client" "2.4.1"--- True------ >>> checkAttrPathVersion "owncloud90" "9.1.3"--- False-checkAttrPathVersion :: Text -> Version -> Bool-checkAttrPathVersion attrPath newVersion =- if "_" `T.isInfixOf` attrPath- then let attrVersionPart =- let (name, version) = clearBreakOn "_" attrPath- in if T.any (notElemOf ('_' : ['0' .. '9'])) version- then Nothing- else Just version- -- Check assuming version part has underscore separators- attrVersionPeriods = T.replace "_" "." <$> attrVersionPart- -- If we don't find version numbers in the attr path, exit success.- in maybe True (`T.isPrefixOf` newVersion) attrVersionPeriods- -- other path- else let attrVersionPart =- let version = T.dropWhile (notElemOf ['0' .. '9']) attrPath- in if T.any (notElemOf ['0' .. '9']) version- then Nothing- else Just version- -- Check assuming version part is the prefix of the version with dots- -- removed. For example, 91 => "9.1"- noPeriodNewVersion = T.replace "." "" newVersion- -- If we don't find version numbers in the attr path, exit success.- in maybe True (`T.isPrefixOf` noPeriodNewVersion) attrVersionPart+nixBuildOptions :: [String]+nixBuildOptions =+ [ "--option",+ "sandbox",+ "true",+ "--option",+ "restrict-eval",+ "true"+ ]+ <> nixCommonOptions -newtype ExitCode =- ExitCode Int- deriving (Show)+runLog ::+ Member (Embed IO) r =>+ (Text -> IO ()) ->+ Sem ((Output Text) ': r) a ->+ Sem r a+runLog logger =+ interpret \case+ Output o -> embed $ logger o -instance Exception ExitCode+envToken :: IO (Maybe Text)+envToken = fmap tshow <$> getEnv "GITHUB_TOKEN"++localToken :: IO (Maybe Text)+localToken = do+ exists <- fileExist "github_token.txt"+ if exists+ then (Just . T.strip <$> T.readFile "github_token.txt")+ else (return Nothing)++hubFileLocation :: IO (Maybe FilePath)+hubFileLocation = do+ xloc <- fmap (<> "/hub") <$> getEnv "XDG_CONFIG_HOME"+ hloc <- fmap (<> "/.config/hub") <$> getEnv "HOME"+ return (xloc <|> hloc)++hubConfigField :: Text -> IO (Maybe Text)+hubConfigField field = do+ hubFile <- hubFileLocation+ case hubFile of+ Nothing -> return Nothing+ Just file -> do+ exists <- fileExist file+ if not exists+ then return Nothing+ else do+ contents <- T.readFile file+ let splits = T.splitOn field contents+ token = T.takeWhile (/= '\n') $ head (drop 1 splits)+ return $ Just token++getGithubToken :: IO Text+getGithubToken = do+ et <- envToken+ lt <- localToken+ ht <- hubConfigField "oauth_token: "+ return $ fromJust (et <|> lt <|> ht)++getGithubUser :: IO (GH.Name GH.Owner)+getGithubUser = do+ hubUser <- hubConfigField "user: "+ case hubUser of+ Just usr -> return $ GH.mkOwnerName usr+ Nothing -> return $ GH.mkOwnerName "r-ryantm"++stripQuotes :: Text -> Maybe Text+stripQuotes = T.stripPrefix "\"" >=> T.stripSuffix "\""
+ src/Version.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Version+ ( assertCompatibleWithPathPin,+ matchVersion,+ )+where++import Data.Foldable (toList)+import Data.Char (isAlpha, isDigit)+import Data.Function (on)+import qualified Data.PartialOrd as PO+import qualified Data.Text as T+import Data.Versions (SemVer (..), VUnit (..), semver)+import OurPrelude+import Utils++notElemOf :: (Eq a, Foldable t) => t a -> a -> Bool+notElemOf o = not . flip elem o++-- | Similar to @breakOn@, but will not keep the pattern at the beginning of the suffix.+--+-- Examples:+--+-- >>> clearBreakOn "::" "a::b::c"+-- ("a","b::c")+clearBreakOn :: Text -> Text -> (Text, Text)+clearBreakOn boundary string =+ let (prefix, suffix) = T.breakOn boundary string+ in if T.null suffix+ then (prefix, suffix)+ else (prefix, T.drop (T.length boundary) suffix)++-- | Check if attribute path is not pinned to a certain version.+-- If a derivation is expected to stay at certain version branch,+-- it will usually have the branch as a part of the attribute path.+--+-- Examples:+--+-- >>> versionCompatibleWithPathPin "libgit2_0_25" "0.25.3"+-- True+--+-- >>> versionCompatibleWithPathPin "owncloud90" "9.0.3"+-- True+--+-- >>> versionCompatibleWithPathPin "owncloud-client" "2.4.1"+-- True+--+-- >>> versionCompatibleWithPathPin "owncloud90" "9.1.3"+-- False+--+-- >>> versionCompatibleWithPathPin "nodejs-slim-10_x" "11.2.0"+-- False+--+-- >>> versionCompatibleWithPathPin "nodejs-slim-10_x" "10.12.0"+-- True+versionCompatibleWithPathPin :: Text -> Version -> Bool+versionCompatibleWithPathPin attrPath newVer+ | "_x" `T.isSuffixOf` T.toLower attrPath =+ versionCompatibleWithPathPin (T.dropEnd 2 attrPath) newVer+ | "_" `T.isInfixOf` attrPath =+ let attrVersionPart =+ let (_, version) = clearBreakOn "_" attrPath+ in if T.any (notElemOf ('_' : ['0' .. '9'])) version+ then Nothing+ else Just version+ -- Check assuming version part has underscore separators+ attrVersionPeriods = T.replace "_" "." <$> attrVersionPart+ in -- If we don't find version numbers in the attr path, exit success.+ maybe True (`T.isPrefixOf` newVer) attrVersionPeriods+ | otherwise =+ let attrVersionPart =+ let version = T.dropWhile (notElemOf ['0' .. '9']) attrPath+ in if T.any (notElemOf ['0' .. '9']) version+ then Nothing+ else Just version+ -- Check assuming version part is the prefix of the version with dots+ -- removed. For example, 91 => "9.1"+ noPeriodNewVersion = T.replace "." "" newVer+ in -- If we don't find version numbers in the attr path, exit success.+ maybe True (`T.isPrefixOf` noPeriodNewVersion) attrVersionPart++versionIncompatibleWithPathPin :: Text -> Version -> Bool+versionIncompatibleWithPathPin path version =+ not (versionCompatibleWithPathPin path version)++assertCompatibleWithPathPin :: Monad m => UpdateEnv -> Text -> ExceptT Text m ()+assertCompatibleWithPathPin ue attrPath =+ tryAssert+ ( "Version in attr path "+ <> attrPath+ <> " not compatible with "+ <> newVersion ue+ )+ ( not+ ( versionCompatibleWithPathPin attrPath (oldVersion ue)+ && versionIncompatibleWithPathPin attrPath (newVersion ue)+ )+ )++data VersionPart+ = PreReleasePart VersionPart+ | EmptyPart+ | IntPart Word+ | TextPart Text+ deriving (Show, Eq)++data ParsedVersion+ = SemanticVersion SemVer+ | SimpleVersion [VersionPart]+ deriving (Show, Eq)++preReleaseTexts :: [Text]+preReleaseTexts = ["alpha", "beta", "pre", "rc"]++textPart :: Text -> VersionPart+textPart t+ | tLower `elem` preReleaseTexts = PreReleasePart $ TextPart tLower+ | otherwise = TextPart tLower+ where+ tLower = T.toLower t++class SimpleVersion a where+ simpleVersion :: a -> [VersionPart]++instance SimpleVersion Text where+ simpleVersion t+ | digitHead /= "" = IntPart number : simpleVersion digitTail+ | alphaHead /= "" = textPart alphaHead : simpleVersion alphaTail+ | otherwise = []+ where+ t' = T.dropWhile (\c -> not (isAlpha c || isDigit c)) t+ (digitHead, digitTail) = T.span isDigit t'+ number = read $ T.unpack digitHead+ (alphaHead, alphaTail) = T.span isAlpha t'++instance SimpleVersion ParsedVersion where+ simpleVersion (SimpleVersion v) = v+ simpleVersion (SemanticVersion v) = simpleVersion v++instance SimpleVersion SemVer where+ simpleVersion SemVer {_svMajor, _svMinor, _svPatch, _svPreRel} =+ [IntPart _svMajor, IntPart _svMinor, IntPart _svPatch]+ ++ map toPart (concat (fmap toList _svPreRel))+ where+ toPart :: VUnit -> VersionPart+ toPart (Digits i) = IntPart i+ toPart (Str t) =+ case textPart t of+ PreReleasePart p -> PreReleasePart p+ p -> PreReleasePart p++instance SimpleVersion [VersionPart] where+ simpleVersion = id++-- | Pre-release parts come before empty parts, everything else comes after+-- them. Int and text parts compare to themselves as expected and comparison+-- between them is not defined.+instance PO.PartialOrd VersionPart where+ PreReleasePart a <= PreReleasePart b = a PO.<= b+ PreReleasePart _ <= _ = True+ _ <= PreReleasePart _ = False+ EmptyPart <= _ = True+ _ <= EmptyPart = False+ IntPart a <= IntPart b = a <= b+ TextPart a <= TextPart b = a <= b+ _ <= _ = False++-- | If either version contains no comparable parts, the versions are not+-- comparable. If both contain at least some parts, compare parts in order. When+-- a version runs out of parts, its remaining parts are considered empty parts,+-- which come after pre-release parts, but before other parts.+--+-- Examples:+--+-- >>> on PO.compare parseVersion "1.2.3" "1.2.4"+-- Just LT+--+-- >>> on PO.compare parseVersion "1.0" "-"+-- Nothing+--+-- >>> on PO.compare parseVersion "-" "-"+-- Nothing+--+-- >>> on PO.compare parseVersion "1.0" "1_0_0"+-- Just LT+--+-- >>> on PO.compare parseVersion "1.0-pre3" "1.0"+-- Just LT+--+-- >>> on PO.compare parseVersion "1.1" "1.a"+-- Nothing+instance PO.PartialOrd ParsedVersion where+ SemanticVersion a <= SemanticVersion b = a <= b+ SimpleVersion [] <= _ = False+ _ <= SimpleVersion [] = False+ a <= b = on lessOrEq simpleVersion a b+ where+ lessOrEq [] [] = True+ lessOrEq [] ys = lessOrEq [EmptyPart] ys+ lessOrEq xs [] = lessOrEq xs [EmptyPart]+ lessOrEq (x : xs) (y : ys) =+ case PO.compare x y of+ Just LT -> True+ Just EQ -> lessOrEq xs ys+ Just GT -> False+ Nothing -> False++parseVersion :: Version -> ParsedVersion+parseVersion v =+ case semver v of+ Left _ -> SimpleVersion $ simpleVersion v+ Right v' -> SemanticVersion v'++matchUpperBound :: Boundary Version -> Version -> Bool+matchUpperBound Unbounded _ = True+matchUpperBound (Including b) v = parseVersion v PO.<= parseVersion b+matchUpperBound (Excluding b) v = parseVersion v PO.< parseVersion b++matchLowerBound :: Boundary Version -> Version -> Bool+matchLowerBound Unbounded _ = True+matchLowerBound (Including b) v = parseVersion b PO.<= parseVersion v+matchLowerBound (Excluding b) v = parseVersion b PO.< parseVersion v++-- | Reports True only if matcher certainly matches. When the order or equality+-- of versions is ambiguous, return False.+--+-- Examples:+--+-- >>> matchVersion (SingleMatcher "1.2.3") "1_2-3"+-- True+--+-- >>> matchVersion (RangeMatcher Unbounded (Including "1.0-pre3")) "1.0"+-- False+--+-- >>> matchVersion (RangeMatcher Unbounded (Excluding "1.0-rev3")) "1.0"+-- True+matchVersion :: VersionMatcher -> Version -> Bool+matchVersion (SingleMatcher v) v' = parseVersion v PO.== parseVersion v'+matchVersion (RangeMatcher lowerBound upperBound) v =+ matchLowerBound lowerBound v && matchUpperBound upperBound v
+ test/CheckSpec.hs view
@@ -0,0 +1,27 @@+module CheckSpec where++import qualified Data.Text as T+import Test.Hspec+import qualified Check++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "version check" do+ let seaweedVersion234 = T.pack "version 30GB 2.34 linux amd64"+ it "finds the version when present" do+ Check.hasVersion (T.pack "The version is 2.34") (T.pack "2.34") `shouldBe` True+ Check.hasVersion (T.pack "The version is 2.34.") (T.pack "2.34") `shouldBe` True+ Check.hasVersion (T.pack "2.34 is the version") (T.pack "2.34") `shouldBe` True+ Check.hasVersion seaweedVersion234 (T.pack "2.34") `shouldBe` True++ it "doesn't produce false positives" do+ Check.hasVersion (T.pack "The version is 12.34") (T.pack "2.34") `shouldBe` False+ Check.hasVersion (T.pack "The version is 2.345") (T.pack "2.34") `shouldBe` False+ Check.hasVersion (T.pack "The version is 2.35") (T.pack "2.34") `shouldBe` False+ Check.hasVersion (T.pack "2.35 is the version") (T.pack "2.34") `shouldBe` False+ Check.hasVersion (T.pack "2.345 is the version") (T.pack "2.34") `shouldBe` False+ Check.hasVersion (T.pack "12.34 is the version") (T.pack "2.34") `shouldBe` False+ Check.hasVersion seaweedVersion234 (T.pack "2.35") `shouldBe` False
+ test/DoctestSpec.hs view
@@ -0,0 +1,33 @@+module DoctestSpec where++import Test.DocTest+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "Doctests" do+ it "should all pass" do+ doctest+ [ "-isrc",+ "-XOverloadedStrings",+ "-XDataKinds",+ "-XFlexibleContexts",+ "-XGADTs",+ "-XLambdaCase",+ "-XPolyKinds",+ "-XRankNTypes",+ "-XScopedTypeVariables",+ "-XTypeApplications",+ "-XTypeFamilies",+ "-XTypeOperators",+ "-XBlockArguments",+ "-flate-specialise",+ "-fspecialise-aggressively",+ "-fplugin=Polysemy.Plugin",+ "src/Version.hs",+ "src/GH.hs",+ "src/Time.hs"+ ]
+ test/RewriteSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module RewriteSpec where++import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified File+import OurPrelude+import qualified Polysemy.Error as Error+import qualified Polysemy.Output as Output+import qualified Process+import qualified Rewrite+import Test.Hspec+import qualified Utils++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "Rewrite.quotedUrls" do+ it "quotes an unquoted meta.homepage URL" do+ nixQuotedHomepageBad <- T.readFile "test_data/quoted_homepage_bad.nix"+ nixQuotedHomepageGood <- T.readFile "test_data/quoted_homepage_good.nix"+ let options = Utils.Options False False "r-ryantm" "" False False False+ let updateEnv = Utils.UpdateEnv "inadyn" "2.5" "2.6" Nothing options+ -- TODO test correct file is being read+ let rwArgs = Rewrite.Args updateEnv "inadyn" undefined undefined False+ (logs, (newContents, result)) <-+ ( runFinal+ . embedToFinal+ . Output.runOutputList+ . File.runPure [nixQuotedHomepageBad]+ . Process.runPure ["\"http://troglobit.com/project/inadyn/\""]+ . Error.errorToIOFinal+ $ Rewrite.quotedUrls rwArgs+ )+ T.putStrLn $ T.unlines logs+ head logs `shouldBe` "[quotedUrls]"+ result `shouldBe` Right (Just "Quoted meta.homepage for [RFC 45](https://github.com/NixOS/rfcs/pull/45)")+ head newContents `shouldBe` nixQuotedHomepageGood
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/UpdateSpec.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}++module UpdateSpec where++import qualified Data.Text.IO as T+import Test.Hspec+import qualified Update+import qualified Utils++main :: IO ()+main = hspec spec++-- Tests here will write their actual results to an actual*.md file next to the+-- expected one. If you are updating the PR description, run the test suite and+-- copy all the actuals over to expected. This can be viewed with `git diff`+-- then to ensure your changes look as expected.+spec :: Spec+spec = do+ describe "PR message" do+ -- Common mock options+ let options = Utils.Options False False "r-ryantm" "" False False False+ let updateEnv = Utils.UpdateEnv "foobar" "1.0" "1.1" (Just "https://update-site.com") options+ let isBroken = False+ let metaDescription = "\"Foobar package description\""+ let metaHomepage = "\"https://foobar-homepage.com\""+ let metaChangelog = "\"https://foobar-homepage.com/changelog/v1.2.3\""+ let rewriteMsgs = ["Version Update", "Other Update"]+ let releaseUrl = "https://github.com/foobar/releases"+ let compareUrl = "https://github.com/foobar/compare"+ let resultCheckReport = "- Some other check"+ let commitHash = "af39cf77a0d42a4f6771043ec54221ed"+ let attrPath = "foobar"+ let maintainersCc = "@maintainer1"+ let resultPath = "/nix/store/some-hash-path"+ let opReport = "123 total rebuild path(s)"+ let cveRep = ""+ let cachixTestInstructions = ""+ let nixpkgsReviewMsg = "nixpkgs-review comment body"++ it "matches a simple mock example" do+ expected <- T.readFile "test_data/expected_pr_description_1.md"+ let actual = Update.prMessage updateEnv isBroken metaDescription metaHomepage metaChangelog rewriteMsgs releaseUrl compareUrl resultCheckReport commitHash attrPath maintainersCc resultPath opReport cveRep cachixTestInstructions nixpkgsReviewMsg+ T.writeFile "test_data/actual_pr_description_1.md" actual+ actual `shouldBe` expected++ it "does not include NixPkgs review section when no review was done" do+ expected <- T.readFile "test_data/expected_pr_description_2.md"+ let nixpkgsReviewMsg' = ""+ let actual = Update.prMessage updateEnv isBroken metaDescription metaHomepage metaChangelog rewriteMsgs releaseUrl compareUrl resultCheckReport commitHash attrPath maintainersCc resultPath opReport cveRep cachixTestInstructions nixpkgsReviewMsg'+ T.writeFile "test_data/actual_pr_description_2.md" actual+ actual `shouldBe` expected
+ test/UtilsSpec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}++module UtilsSpec where++import Test.Hspec+import qualified Utils++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "PR title" do+ -- This breaks IRC when it tries to link to newly opened pull requests+ it "should not include a trailing newline" do+ let options = Utils.Options False False "" "" False False False+ let updateEnv = Utils.UpdateEnv "foobar" "1.0" "1.1" (Just "https://update-site.com") options+ let title = Utils.prTitle updateEnv "python37Packages.foobar"+ title `shouldBe` "python37Packages.foobar: 1.0 -> 1.1"
− test/doctests.hs
@@ -1,3 +0,0 @@-import Test.DocTest--main = doctest ["-isrc", "-XOverloadedStrings", "src/Utils.hs"]