diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,24 +1,284 @@ # nixpkgs-update -[![Build Status](https://travis-ci.org/ryantm/nixpkgs-update.svg?branch=master)](https://travis-ci.org/ryantm/nixpkgs-update) +[![Build Status](https://github.com/ryantm/nixpkgs-update/workflows/CI/badge.svg)](https://github.com/ryantm/nixpkgs-update/actions) +[![Patreon](https://img.shields.io/badge/patreon-donate-blue.svg)](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 '' 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. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/nixpkgs-update.cabal b/nixpkgs-update.cabal --- a/nixpkgs-update.cabal +++ b/nixpkgs-update.cabal @@ -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 diff --git a/src/Blacklist.hs b/src/Blacklist.hs deleted file mode 100644 --- a/src/Blacklist.hs +++ /dev/null @@ -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) diff --git a/src/CVE.hs b/src/CVE.hs new file mode 100644 --- /dev/null +++ b/src/CVE.hs @@ -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" diff --git a/src/Check.hs b/src/Check.hs --- a/src/Check.hs +++ b/src/Check.hs @@ -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 + |] diff --git a/src/Clean.hs b/src/Clean.hs deleted file mode 100644 --- a/src/Clean.hs +++ /dev/null @@ -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" diff --git a/src/Data/Hex.hs b/src/Data/Hex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hex.hs @@ -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 diff --git a/src/DeleteMerged.hs b/src/DeleteMerged.hs --- a/src/DeleteMerged.hs +++ b/src/DeleteMerged.hs @@ -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 () diff --git a/src/File.hs b/src/File.hs --- a/src/File.hs +++ b/src/File.hs @@ -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) diff --git a/src/GH.hs b/src/GH.hs --- a/src/GH.hs +++ b/src/GH.hs @@ -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) diff --git a/src/Git.hs b/src/Git.hs --- a/src/Git.hs +++ b/src/Git.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 diff --git a/src/NVD.hs b/src/NVD.hs new file mode 100644 --- /dev/null +++ b/src/NVD.hs @@ -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 diff --git a/src/NVDRules.hs b/src/NVDRules.hs new file mode 100644 --- /dev/null +++ b/src/NVDRules.hs @@ -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)) diff --git a/src/Nix.hs b/src/Nix.hs --- a/src/Nix.hs +++ b/src/Nix.hs @@ -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] diff --git a/src/NixpkgsReview.hs b/src/NixpkgsReview.hs new file mode 100644 --- /dev/null +++ b/src/NixpkgsReview.hs @@ -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 diff --git a/src/OurPrelude.hs b/src/OurPrelude.hs new file mode 100644 --- /dev/null +++ b/src/OurPrelude.hs @@ -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 diff --git a/src/Outpaths.hs b/src/Outpaths.hs --- a/src/Outpaths.hs +++ b/src/Outpaths.hs @@ -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 + |] diff --git a/src/Process.hs b/src/Process.hs new file mode 100644 --- /dev/null +++ b/src/Process.hs @@ -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) diff --git a/src/Repology.hs b/src/Repology.hs new file mode 100644 --- /dev/null +++ b/src/Repology.hs @@ -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 () diff --git a/src/Rewrite.hs b/src/Rewrite.hs new file mode 100644 --- /dev/null +++ b/src/Rewrite.hs @@ -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 () diff --git a/src/Skiplist.hs b/src/Skiplist.hs new file mode 100644 --- /dev/null +++ b/src/Skiplist.hs @@ -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 diff --git a/src/Time.hs b/src/Time.hs new file mode 100644 --- /dev/null +++ b/src/Time.hs @@ -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 diff --git a/src/Update.hs b/src/Update.hs --- a/src/Update.hs +++ b/src/Update.hs @@ -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 +
- Checks done (click to expand) + Checks done (click to expand) + --- + - built on NixOS $resultCheckReport + --- +
- Instructions to test this update (click to expand) + Rebuild report (if merged into master) (click to expand) - 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: +
+ +
+ + Instructions to test this update (click to expand) + + + --- + + $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 ``` + ---

+ + $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 + +
+ + Security report (click to expand) + + + CVEs resolved by this update: + $fixedList + + CVEs introduced by this update: + $newList + + CVEs present in both versions: + $unresolvedList + + +
+
+ |] + +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 diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 "\"" diff --git a/src/Version.hs b/src/Version.hs new file mode 100644 --- /dev/null +++ b/src/Version.hs @@ -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 diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs new file mode 100644 --- /dev/null +++ b/test/CheckSpec.hs @@ -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 diff --git a/test/DoctestSpec.hs b/test/DoctestSpec.hs new file mode 100644 --- /dev/null +++ b/test/DoctestSpec.hs @@ -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" + ] diff --git a/test/RewriteSpec.hs b/test/RewriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/RewriteSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/UpdateSpec.hs b/test/UpdateSpec.hs new file mode 100644 --- /dev/null +++ b/test/UpdateSpec.hs @@ -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 diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs new file mode 100644 --- /dev/null +++ b/test/UtilsSpec.hs @@ -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" diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Test.DocTest - -main = doctest ["-isrc", "-XOverloadedStrings", "src/Utils.hs"]