diff --git a/cabal.project b/cabal.project index 6c26f75b..fa5275b6 100644 --- a/cabal.project +++ b/cabal.project @@ -2,6 +2,7 @@ tests: true benchmarks: true packages: + ./hnix-store-aterm/hnix-store-aterm.cabal ./hnix-store-core/hnix-store-core.cabal ./hnix-store-db/hnix-store-db.cabal ./hnix-store-json/hnix-store-json.cabal diff --git a/cabal.project.local.ci b/cabal.project.local.ci index 764e06a8..58530e17 100644 --- a/cabal.project.local.ci +++ b/cabal.project.local.ci @@ -1,3 +1,6 @@ +package hnix-store-aterm + ghc-options: -Wunused-packages -Wall -Werror + package hnix-store-core ghc-options: -Wunused-packages -Wall -Werror diff --git a/default.nix b/default.nix index f42d46ec..a198197e 100644 --- a/default.nix +++ b/default.nix @@ -20,6 +20,7 @@ let haskellPackages = packageSet.override overrideHaskellPackages; in { inherit (haskellPackages) + hnix-store-aterm hnix-store-core hnix-store-db hnix-store-json diff --git a/hnix-store-aterm/LICENSE b/hnix-store-aterm/LICENSE new file mode 100644 index 00000000..28508197 --- /dev/null +++ b/hnix-store-aterm/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2017 Gabriella Gonzalez +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriella Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/hnix-store-aterm/README.md b/hnix-store-aterm/README.md new file mode 100644 index 00000000..1528f2aa --- /dev/null +++ b/hnix-store-aterm/README.md @@ -0,0 +1,218 @@ +# `hnix-store-aterm` + +[![GitHub Workflow Status](https://img.shields.io/github/actions/workflow/status/Gabriella439/Haskell-Nix-Derivation-Library/ci.yaml?branch=main)](https://github.com/Gabriella439/Haskell-Nix-Derivation-Library/actions/workflows/ci.yaml) +[![Hackage version](https://img.shields.io/hackage/v/hnix-store-aterm.svg?color=success)](https://hackage.haskell.org/package/hnix-store-aterm) +[![Dependencies](https://img.shields.io/hackage-deps/v/hnix-store-aterm?label=Dependencies)](https://packdeps.haskellers.com/feed?needle=hnix-store-aterm) + +Use this package to parse and render Nix derivations such as those stored +in `/nix/store/*.drv` files. For example, if you had the following derivation +saved at +`/nix/store/zzhs4fb83x5ygvjqn5rdpmpnishpdgy6-perl-MIME-Types-2.13.drv`: + +``` +Derive([("devdoc","/nix/store/15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl-MIME-Types-2 +.13-devdoc","",""),("out","/nix/store/93d75ghjyibmbxgfzwhh4b5zwsxzs44w-perl-MIME +-Types-2.13","","")],[("/nix/store/57h2hjsdkdiwbzilcjqkn46138n1xb4a-perl-5.22.3. +drv",["out"]),("/nix/store/cvdbbvnvg131bz9bwyyk97jpq1crclqr-MIME-Types-2.13.tar. +gz.drv",["out"]),("/nix/store/p5g31bc5x92awghx9dlm065d7j773l0r-stdenv.drv",["out +"]),("/nix/store/x50y5qihwsn0lfjhrf1s81b5hgb9w632-bash-4.4-p5.drv",["out"])],["/ +nix/store/cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.sh"],"x86_64-linux","/nix/sto +re/fi3mbd2ml4pbgzyasrlnp0wyy6qi48fh-bash-4.4-p5/bin/bash",["-e","/nix/store/cdip +s4lakfk1qbf1x68fq18wnn3r5r14-builder.sh"],[("AUTOMATED_TESTING","1"),("PERL_AUTO +INSTALL","--skipdeps"),("buildInputs",""),("builder","/nix/store/fi3mbd2ml4pbgzy +asrlnp0wyy6qi48fh-bash-4.4-p5/bin/bash"),("checkTarget","test"),("devdoc","/nix/ +store/15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl-MIME-Types-2.13-devdoc"),("doCheck", +"1"),("installTargets","pure_install"),("name","perl-MIME-Types-2.13"),("nativeB +uildInputs","/nix/store/nsa311yg8h93wfaacjk16c96a98bs09f-perl-5.22.3"),("out","/ +nix/store/93d75ghjyibmbxgfzwhh4b5zwsxzs44w-perl-MIME-Types-2.13"),("outputs","ou +t devdoc"),("propagatedBuildInputs",""),("propagatedNativeBuildInputs",""),("src +","/nix/store/5smhymz7viq8p47mc3jgyvqd003ab732-MIME-Types-2.13.tar.gz"),("stdenv +","/nix/store/s3rlr45jzlzx0d6k2azlpxa5zwzr7xyy-stdenv"),("system","x86_64-linux" +)]) +``` + +... you could parse that derivation using: + +``` +>>> text <- Data.Text.Lazy.IO.readFile "/nix/store/zzhs4fb83x5ygvjqn5rdpmpnishpdgy6-perl-MIME-Types-2.13.drv" +>>> let result = Data.Attoparsec.Text.Lazy.parse System.Nix.Derivation.ATerm.parseDerivation text +>>> result +Done "" (Derivation {outputs = fromList [("devdoc",DerivationOutput {path = File +Path "/nix/store/15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl-MIME-Types-2.13-devdoc", +hashAlgo = "", hash = ""}),("out",DerivationOutput {path = FilePath "/nix/store/ +93d75ghjyibmbxgfzwhh4b5zwsxzs44w-perl-MIME-Types-2.13", hashAlgo = "", hash = "" +})], inputDrvs = fromList [(FilePath "/nix/store/57h2hjsdkdiwbzilcjqkn46138n1xb4 +a-perl-5.22.3.drv",fromList ["out"]),(FilePath "/nix/store/cvdbbvnvg131bz9bwyyk9 +7jpq1crclqr-MIME-Types-2.13.tar.gz.drv",fromList ["out"]),(FilePath "/nix/store/ +p5g31bc5x92awghx9dlm065d7j773l0r-stdenv.drv",fromList ["out"]),(FilePath "/nix/s +tore/x50y5qihwsn0lfjhrf1s81b5hgb9w632-bash-4.4-p5.drv",fromList ["out"])], input +Srcs = fromList [FilePath "/nix/store/cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.s +h"], platform = "x86_64-linux", builder = FilePath "/nix/store/fi3mbd2ml4pbgzyas +rlnp0wyy6qi48fh-bash-4.4-p5/bin/bash", args = ["-e","/nix/store/cdips4lakfk1qbf1 +x68fq18wnn3r5r14-builder.sh"], env = fromList [("AUTOMATED_TESTING","1"),("PERL_ +AUTOINSTALL","--skipdeps"),("buildInputs",""),("builder","/nix/store/fi3mbd2ml4p +bgzyasrlnp0wyy6qi48fh-bash-4.4-p5/bin/bash"),("checkTarget","test"),("devdoc","/ +nix/store/15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl-MIME-Types-2.13-devdoc"),("doChe +ck","1"),("installTargets","pure_install"),("name","perl-MIME-Types-2.13"),("nat +iveBuildInputs","/nix/store/nsa311yg8h93wfaacjk16c96a98bs09f-perl-5.22.3"),("out +","/nix/store/93d75ghjyibmbxgfzwhh4b5zwsxzs44w-perl-MIME-Types-2.13"),("outputs" +,"out devdoc"),("propagatedBuildInputs",""),("propagatedNativeBuildInputs",""),( +"src","/nix/store/5smhymz7viq8p47mc3jgyvqd003ab732-MIME-Types-2.13.tar.gz"),("st +denv","/nix/store/s3rlr45jzlzx0d6k2azlpxa5zwzr7xyy-stdenv"),("system","x86_64-li +nux")]}) +``` + +... and render the result back to the original derivation: + +``` +>>> fmap buildDerivation result +Done "" "Derive([(\"devdoc\",\"/nix/store/15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl- +MIME-Types-2.13-devdoc\",\"\",\"\"),(\"out\",\"/nix/store/93d75ghjyibmbxgfzwhh4b +5zwsxzs44w-perl-MIME-Types-2.13\",\"\",\"\")],[(\"/nix/store/57h2hjsdkdiwbzilcjq +kn46138n1xb4a-perl-5.22.3.drv\",[\"out\"]),(\"/nix/store/cvdbbvnvg131bz9bwyyk97j +pq1crclqr-MIME-Types-2.13.tar.gz.drv\",[\"out\"]),(\"/nix/store/p5g31bc5x92awghx +9dlm065d7j773l0r-stdenv.drv\",[\"out\"]),(\"/nix/store/x50y5qihwsn0lfjhrf1s81b5h +gb9w632-bash-4.4-p5.drv\",[\"out\"])],[\"/nix/store/cdips4lakfk1qbf1x68fq18wnn3r +5r14-builder.sh\"],\"x86_64-linux\",\"/nix/store/fi3mbd2ml4pbgzyasrlnp0wyy6qi48f +h-bash-4.4-p5/bin/bash\",[\"-e\",\"/nix/store/cdips4lakfk1qbf1x68fq18wnn3r5r14-b +uilder.sh\"],[(\"AUTOMATED_TESTING\",\"1\"),(\"PERL_AUTOINSTALL\",\"--skipdeps\" +),(\"buildInputs\",\"\"),(\"builder\",\"/nix/store/fi3mbd2ml4pbgzyasrlnp0wyy6qi4 +8fh-bash-4.4-p5/bin/bash\"),(\"checkTarget\",\"test\"),(\"devdoc\",\"/nix/store/ +15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl-MIME-Types-2.13-devdoc\"),(\"doCheck\",\"1 +\"),(\"installTargets\",\"pure_install\"),(\"name\",\"perl-MIME-Types-2.13\"),(\ +"nativeBuildInputs\",\"/nix/store/nsa311yg8h93wfaacjk16c96a98bs09f-perl-5.22.3\" +),(\"out\",\"/nix/store/93d75ghjyibmbxgfzwhh4b5zwsxzs44w-perl-MIME-Types-2.13\") +,(\"outputs\",\"out devdoc\"),(\"propagatedBuildInputs\",\"\"),(\"propagatedNati +veBuildInputs\",\"\"),(\"src\",\"/nix/store/5smhymz7viq8p47mc3jgyvqd003ab732-MIM +E-Types-2.13.tar.gz\"),(\"stdenv\",\"/nix/store/s3rlr45jzlzx0d6k2azlpxa5zwzr7xyy +-stdenv\"),(\"system\",\"x86_64-linux\")])" +``` + +You can also use the `pretty-derivation` executable installed as part of this +package to pretty-print the Haskell representation of a Nix derivations: + +```shell +$ pretty-derivation < /nix/store/0008hdcdvkrr5mcqahy416hv6rmb5fwg-void-0.7.1.tar.gz.drv +Derivation + { outputs = + fromList + [ ( "out" + , DerivationOutput + { path = + FilePath + "/nix/store/fbbqa4x05q9x0w6s1fqmx7k676d2zyz1-void-0.7.1.tar.gz" + , hashAlgo = "sha256" + , hash = + "c9f0fd93680c029abb9654b5464be260652829961b18b7046f96a0df95e825f4" + } + ) + ] + , inputDrvs = + fromList + [ ( FilePath + "/nix/store/cwnn2alfww3six2ywph5hnnlmxwhv9c7-curl-7.52.1.drv" + , fromList [ "dev" ] + ) + , ( FilePath + "/nix/store/kzs0g1ch3a59ar14xnms1wj22p2bnr9l-stdenv.drv" + , fromList [ "out" ] + ) + , ( FilePath + "/nix/store/qq7pqyfn98314fd30xspb1hi3rqda2lh-bash-4.3-p48.drv" + , fromList [ "out" ] + ) + , ( FilePath + "/nix/store/r1b0rbna957biiy63m75yxsw3aphps9b-mirrors-list.drv" + , fromList [ "out" ] + ) + ] + , inputSrcs = + fromList + [ FilePath "/nix/store/5pqfb6ik1cxqq1d0irlx3060jx1qjmsn-builder.sh" + ] + , platform = "x86_64-linux" + , builder = + "/nix/store/gabjbkwga2dhhp2wzyaxl83r8hjjfc37-bash-4.3-p48/bin/bash" + , args = + [ "-e" , "/nix/store/5pqfb6ik1cxqq1d0irlx3060jx1qjmsn-builder.sh" ] + , env = + fromList + [ ( "buildInputs" , "" ) + , ( "builder" + , "/nix/store/gabjbkwga2dhhp2wzyaxl83r8hjjfc37-bash-4.3-p48/bin/bash" + ) + , ( "curlOpts" , "" ) + , ( "downloadToTemp" , "" ) + , ( "executable" , "" ) + , ( "impureEnvVars" + , "http_proxy https_proxy ftp_proxy all_proxy no_proxy NIX_CURL_FLAGS NIX_HASHED_MIRRORS NIX_CONNECT_TIMEOUT NIX_MIRRORS_apache NIX_MIRRORS_bioc NIX_MIRRORS_bitlbee NIX_MIRRORS_cpan NIX_MIRRORS_debian NIX_MIRRORS_fedora NIX_MIRRORS_gcc NIX_MIRRORS_gentoo NIX_MIRRORS_gnome NIX_MIRRORS_gnu NIX_MIRRORS_gnupg NIX_MIRRORS_hackage NIX_MIRRORS_hashedMirrors NIX_MIRRORS_imagemagick NIX_MIRRORS_kde NIX_MIRRORS_kernel NIX_MIRRORS_metalab NIX_MIRRORS_mozilla NIX_MIRRORS_mysql NIX_MIRRORS_oldsuse NIX_MIRRORS_openbsd NIX_MIRRORS_opensuse NIX_MIRRORS_postgresql NIX_MIRRORS_pypi NIX_MIRRORS_roy NIX_MIRRORS_sagemath NIX_MIRRORS_samba NIX_MIRRORS_savannah NIX_MIRRORS_sourceforge NIX_MIRRORS_sourceforgejp NIX_MIRRORS_steamrt NIX_MIRRORS_ubuntu NIX_MIRRORS_xfce NIX_MIRRORS_xorg" + ) + , ( "mirrorsFile" + , "/nix/store/ab4zh0ga99y5xj441arp89zl8s4jfc7y-mirrors-list" + ) + , ( "name" , "void-0.7.1.tar.gz" ) + , ( "nativeBuildInputs" + , "/nix/store/3ngwsbzhibvc434nqwq6jph6w7c2was6-curl-7.52.1-dev" + ) + , ( "out" + , "/nix/store/fbbqa4x05q9x0w6s1fqmx7k676d2zyz1-void-0.7.1.tar.gz" + ) + , ( "outputHash" + , "c9f0fd93680c029abb9654b5464be260652829961b18b7046f96a0df95e825f4" + ) + , ( "outputHashAlgo" , "sha256" ) + , ( "outputHashMode" , "flat" ) + , ( "postFetch" , "" ) + , ( "preferHashedMirrors" , "1" ) + , ( "preferLocalBuild" , "1" ) + , ( "propagatedBuildInputs" , "" ) + , ( "propagatedNativeBuildInputs" , "" ) + , ( "showURLs" , "" ) + , ( "stdenv" + , "/nix/store/985d95clq0216a6pcp3qzw4igp84ajvr-stdenv" + ) + , ( "system" , "x86_64-linux" ) + , ( "urls" , "mirror://hackage/void-0.7.1.tar.gz" ) + ] + } +``` + +## Installation + +With Nix: + +``` +$ nix-env -iA nixpkgs.haskellPackages.hnix-store-aterm +``` + +## Development status + +If you would like to add support for additional functionality, just open an +issue or pull request + +## License (BSD 3-clause) + + Copyright (c) 2017 Gabriella Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriella Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/hnix-store-aterm/Setup.hs b/hnix-store-aterm/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/hnix-store-aterm/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hnix-store-aterm/bench/Main.hs b/hnix-store-aterm/bench/Main.hs new file mode 100644 index 00000000..dae3e228 --- /dev/null +++ b/hnix-store-aterm/bench/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +import Criterion (Benchmark) + +import Criterion qualified +import Criterion.Main qualified +import Data.Attoparsec.Text.Lazy qualified +import Data.Text.Lazy.IO qualified + +import System.Nix.StorePath +import System.Nix.Derivation.ATerm qualified + +main :: IO () +main = Criterion.Main.defaultMain benchmarks + +benchmarks :: [Benchmark] +benchmarks = + [ Criterion.Main.env + (Data.Text.Lazy.IO.readFile "tests/example1.drv") + bench0 + ] + where + bench0 example = + Criterion.bench "example" (Criterion.nf parseExample example) + + parseExample = + Data.Attoparsec.Text.Lazy.parse $ + System.Nix.Derivation.ATerm.parseTraditionalDerivation + (StoreDir "/nix/store") diff --git a/hnix-store-aterm/hnix-store-aterm.cabal b/hnix-store-aterm/hnix-store-aterm.cabal new file mode 100644 index 00000000..38bd8921 --- /dev/null +++ b/hnix-store-aterm/hnix-store-aterm.cabal @@ -0,0 +1,120 @@ +Cabal-Version: 2.2 +Name: hnix-store-aterm +Version: 1.1.3 +Build-Type: Simple +Tested-With: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.8.3 +License: BSD-3-Clause +License-File: LICENSE +Copyright: 2017 Gabriella Gonzalez +Author: Gabriella Gonzalez +Maintainer: GenuineGabriella@gmail.com +Bug-Reports: https://github.com/Gabriella439/Haskell-Nix-Derivation-Library/issues +Synopsis: Parse and render *.drv files +Description: + Use this package to parse and render Nix derivation files (i.e. *.drv files), + i.e. Nix Derivations in "ATerm" format. + . + See + https://nix.dev/manual/nix/latest/protocols/derivation-aterm.html + for more details about this format. + . + This package also provides a @pretty-derivation@ executable which reads a + derivation on standard input and outputs the pretty-printed Haskell + representation on standard output +Category: System +Extra-Source-Files: + tests/example0.drv + tests/example1.drv +Source-Repository head + Type: git + Location: https://github.com/Gabriella439/Haskell-Nix-Derivation-Library + +Common commons + Default-Extensions: + ImportQualifiedPost + Default-Language: Haskell2010 + +Library + Import: commons + Hs-Source-Dirs: src + Build-Depends: + attoparsec >= 0.12.0.0 && < 0.15, + base >= 4.6.0.0 && < 5 , + constraints-extras, + containers < 0.8 , + deepseq >= 1.4.0.0 && < 1.6 , + dependent-sum, + hnix-store-core, + monoidal-containers, + some, + text >= 0.8.0.0 && < 2.2 , + these, + vector < 0.14 + Exposed-Modules: + System.Nix.Derivation.ATerm + System.Nix.Derivation.Traditional + Other-Modules: + System.Nix.Derivation.ATerm.Builder, + System.Nix.Derivation.ATerm.Parser + GHC-Options: -Wall + +Executable pretty-derivation + Import: commons + Hs-Source-Dirs: pretty-derivation + Build-Depends: + base >= 4.6.0.0 && < 5 , + attoparsec >= 0.12.0.0 && < 0.15, + pretty-show >= 1.6.11 && < 1.11, + text , + hnix-store-core , + hnix-store-aterm + GHC-Options: -Wall + Main-Is: Main.hs + +Test-Suite example + Import: commons + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests + Main-Is: Example.hs + GHC-Options: -Wall + Build-Depends: + base >= 4.6.0.0 && < 5 , + attoparsec >= 0.12.0.0 && < 0.15, + hnix-store-core , + hnix-store-aterm , + text + +Test-Suite property + Import: commons + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests + Main-Is: Property.hs + GHC-Options: -Wall + Build-Depends: + base >= 4.6.0.0 && < 5 , + attoparsec >= 0.12.0.0 && < 0.15, + hnix-store-core , + hnix-store-aterm , + hnix-store-tests , + containers , + generic-arbitrary < 1.1 , + QuickCheck < 2.16, + text , + these , + vector < 0.14, + filepath < 1.5 + +Benchmark benchmark + Import: commons + Type: exitcode-stdio-1.0 + HS-Source-Dirs: bench + Main-Is: Main.hs + GHC-Options: -Wall + + Build-Depends: + base >= 4.6.0.0 && < 5 , + attoparsec >= 0.12.0.0 && < 0.15, + criterion >= 1.1.4.0 && < 1.7 , + hnix-store-core , + hnix-store-aterm , + text diff --git a/hnix-store-aterm/pretty-derivation/Main.hs b/hnix-store-aterm/pretty-derivation/Main.hs new file mode 100644 index 00000000..259b3489 --- /dev/null +++ b/hnix-store-aterm/pretty-derivation/Main.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Attoparsec.Text.Lazy (Result(..)) +import Data.Attoparsec.Text.Lazy qualified +import Data.Text.Lazy.IO qualified +import Text.Show.Pretty qualified + +import System.Nix.StorePath +import System.Nix.Derivation.ATerm qualified + +main :: IO () +main = do + text <- Data.Text.Lazy.IO.getContents + case + Data.Attoparsec.Text.Lazy.parse + (System.Nix.Derivation.ATerm.parseTraditionalDerivation + (StoreDir "/nix/store")) + text + of + Fail _ _ err -> fail err + Done _ derivation -> Text.Show.Pretty.pPrint derivation diff --git a/hnix-store-aterm/src/System/Nix/Derivation/ATerm.hs b/hnix-store-aterm/src/System/Nix/Derivation/ATerm.hs new file mode 100644 index 00000000..d8e7075e --- /dev/null +++ b/hnix-store-aterm/src/System/Nix/Derivation/ATerm.hs @@ -0,0 +1,104 @@ +-- | Use this package to parse and render Nix derivations such as those stored +-- in @\/nix\/store\/*.drv@ files. For example, if you had the following derivation +-- saved at +-- @\/nix\/store\/zzhs4fb83x5ygvjqn5rdpmpnishpdgy6-perl-MIME-Types-2.13.drv@: +-- +-- > Derive([("devdoc","/nix/store/15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl-MIME-Types-2 +-- > .13-devdoc","",""),("out","/nix/store/93d75ghjyibmbxgfzwhh4b5zwsxzs44w-perl-MIME +-- > -Types-2.13","","")],[("/nix/store/57h2hjsdkdiwbzilcjqkn46138n1xb4a-perl-5.22.3. +-- > drv",["out"]),("/nix/store/cvdbbvnvg131bz9bwyyk97jpq1crclqr-MIME-Types-2.13.tar. +-- > gz.drv",["out"]),("/nix/store/p5g31bc5x92awghx9dlm065d7j773l0r-stdenv.drv",["out +-- > "]),("/nix/store/x50y5qihwsn0lfjhrf1s81b5hgb9w632-bash-4.4-p5.drv",["out"])],["/ +-- > nix/store/cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.sh"],"x86_64-linux","/nix/sto +-- > re/fi3mbd2ml4pbgzyasrlnp0wyy6qi48fh-bash-4.4-p5/bin/bash",["-e","/nix/store/cdip +-- > s4lakfk1qbf1x68fq18wnn3r5r14-builder.sh"],[("AUTOMATED_TESTING","1"),("PERL_AUTO +-- > INSTALL","--skipdeps"),("buildInputs",""),("builder","/nix/store/fi3mbd2ml4pbgzy +-- > asrlnp0wyy6qi48fh-bash-4.4-p5/bin/bash"),("checkTarget","test"),("devdoc","/nix/ +-- > store/15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl-MIME-Types-2.13-devdoc"),("doCheck", +-- > "1"),("installTargets","pure_install"),("name","perl-MIME-Types-2.13"),("nativeB +-- > uildInputs","/nix/store/nsa311yg8h93wfaacjk16c96a98bs09f-perl-5.22.3"),("out","/ +-- > nix/store/93d75ghjyibmbxgfzwhh4b5zwsxzs44w-perl-MIME-Types-2.13"),("outputs","ou +-- > t devdoc"),("propagatedBuildInputs",""),("propagatedNativeBuildInputs",""),("src +-- > ","/nix/store/5smhymz7viq8p47mc3jgyvqd003ab732-MIME-Types-2.13.tar.gz"),("stdenv +-- > ","/nix/store/s3rlr45jzlzx0d6k2azlpxa5zwzr7xyy-stdenv"),("system","x86_64-linux" +-- > )]) +-- +-- ... you could parse that derivation using: +-- +-- >>> text <- Data.Text.Lazy.IO.readFile "/nix/store/zzhs4fb83x5ygvjqn5rdpmpnishpdgy6-perl-MIME-Types-2.13.drv" +-- >>> let result = Data.Attoparsec.Text.Lazy.parse System.Nix.Derivation.ATerm.parseDerivation text +-- >>> result +-- Done "" (Derivation {outputs = fromList [("devdoc",DerivationOutput {path = File +-- Path "/nix/store/15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl-MIME-Types-2.13-devdoc", +-- hashAlgo = "", hash = ""}),("out",DerivationOutput {path = FilePath "/nix/store/ +-- 93d75ghjyibmbxgfzwhh4b5zwsxzs44w-perl-MIME-Types-2.13", hashAlgo = "", hash = "" +-- })], inputDrvs = fromList [(FilePath "/nix/store/57h2hjsdkdiwbzilcjqkn46138n1xb4 +-- a-perl-5.22.3.drv",fromList ["out"]),(FilePath "/nix/store/cvdbbvnvg131bz9bwyyk9 +-- 7jpq1crclqr-MIME-Types-2.13.tar.gz.drv",fromList ["out"]),(FilePath "/nix/store/ +-- p5g31bc5x92awghx9dlm065d7j773l0r-stdenv.drv",fromList ["out"]),(FilePath "/nix/s +-- tore/x50y5qihwsn0lfjhrf1s81b5hgb9w632-bash-4.4-p5.drv",fromList ["out"])], input +-- Srcs = fromList [FilePath "/nix/store/cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.s +-- h"], platform = "x86_64-linux", builder = FilePath "/nix/store/fi3mbd2ml4pbgzyas +-- rlnp0wyy6qi48fh-bash-4.4-p5/bin/bash", args = ["-e","/nix/store/cdips4lakfk1qbf1 +-- x68fq18wnn3r5r14-builder.sh"], env = fromList [("AUTOMATED_TESTING","1"),("PERL_ +-- AUTOINSTALL","--skipdeps"),("buildInputs",""),("builder","/nix/store/fi3mbd2ml4p +-- bgzyasrlnp0wyy6qi48fh-bash-4.4-p5/bin/bash"),("checkTarget","test"),("devdoc","/ +-- nix/store/15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl-MIME-Types-2.13-devdoc"),("doChe +-- ck","1"),("installTargets","pure_install"),("name","perl-MIME-Types-2.13"),("nat +-- iveBuildInputs","/nix/store/nsa311yg8h93wfaacjk16c96a98bs09f-perl-5.22.3"),("out +-- ","/nix/store/93d75ghjyibmbxgfzwhh4b5zwsxzs44w-perl-MIME-Types-2.13"),("outputs" +-- ,"out devdoc"),("propagatedBuildInputs",""),("propagatedNativeBuildInputs",""),( +-- "src","/nix/store/5smhymz7viq8p47mc3jgyvqd003ab732-MIME-Types-2.13.tar.gz"),("st +-- denv","/nix/store/s3rlr45jzlzx0d6k2azlpxa5zwzr7xyy-stdenv"),("system","x86_64-li +-- nux")]}) +-- +-- ... and render the result back to the original derivation: +-- +-- >>> fmap buildDerivation result +-- Done "" "Derive([(\"devdoc\",\"/nix/store/15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl- +-- MIME-Types-2.13-devdoc\",\"\",\"\"),(\"out\",\"/nix/store/93d75ghjyibmbxgfzwhh4b +-- 5zwsxzs44w-perl-MIME-Types-2.13\",\"\",\"\")],[(\"/nix/store/57h2hjsdkdiwbzilcjq +-- kn46138n1xb4a-perl-5.22.3.drv\",[\"out\"]),(\"/nix/store/cvdbbvnvg131bz9bwyyk97j +-- pq1crclqr-MIME-Types-2.13.tar.gz.drv\",[\"out\"]),(\"/nix/store/p5g31bc5x92awghx +-- 9dlm065d7j773l0r-stdenv.drv\",[\"out\"]),(\"/nix/store/x50y5qihwsn0lfjhrf1s81b5h +-- gb9w632-bash-4.4-p5.drv\",[\"out\"])],[\"/nix/store/cdips4lakfk1qbf1x68fq18wnn3r +-- 5r14-builder.sh\"],\"x86_64-linux\",\"/nix/store/fi3mbd2ml4pbgzyasrlnp0wyy6qi48f +-- h-bash-4.4-p5/bin/bash\",[\"-e\",\"/nix/store/cdips4lakfk1qbf1x68fq18wnn3r5r14-b +-- uilder.sh\"],[(\"AUTOMATED_TESTING\",\"1\"),(\"PERL_AUTOINSTALL\",\"--skipdeps\" +-- ),(\"buildInputs\",\"\"),(\"builder\",\"/nix/store/fi3mbd2ml4pbgzyasrlnp0wyy6qi4 +-- 8fh-bash-4.4-p5/bin/bash\"),(\"checkTarget\",\"test\"),(\"devdoc\",\"/nix/store/ +-- 15x9ii8c3n5wb5lg80cm8x0yk6zy7rha-perl-MIME-Types-2.13-devdoc\"),(\"doCheck\",\"1 +-- \"),(\"installTargets\",\"pure_install\"),(\"name\",\"perl-MIME-Types-2.13\"),(\ +-- "nativeBuildInputs\",\"/nix/store/nsa311yg8h93wfaacjk16c96a98bs09f-perl-5.22.3\" +-- ),(\"out\",\"/nix/store/93d75ghjyibmbxgfzwhh4b5zwsxzs44w-perl-MIME-Types-2.13\") +-- ,(\"outputs\",\"out devdoc\"),(\"propagatedBuildInputs\",\"\"),(\"propagatedNati +-- veBuildInputs\",\"\"),(\"src\",\"/nix/store/5smhymz7viq8p47mc3jgyvqd003ab732-MIM +-- E-Types-2.13.tar.gz\"),(\"stdenv\",\"/nix/store/s3rlr45jzlzx0d6k2azlpxa5zwzr7xyy +-- -stdenv\"),(\"system\",\"x86_64-linux\")])" + +module System.Nix.Derivation.ATerm + ( -- * Types + TraditionalDerivation'(..) + , FreeformDerivationOutput(..) + , FreeformDerivationOutputs + , TraditionalDerivationInputs(..) + , DerivedPathMap(..) + + -- * Parse derivations + , parseTraditionalDerivation + , parseTraditionalDerivationWith + , parseFreeformDerivationOutput + , parseTraditionalDerivationInputs + , textParser + + -- * Render derivations + , buildTraditionalDerivation + , buildTraditionalDerivationWith + , buildFreeformDerivationOutput + , buildTraditionalDerivationInputs + ) where + +import System.Nix.Derivation +import System.Nix.Derivation.Traditional +import System.Nix.Derivation.ATerm.Builder +import System.Nix.Derivation.ATerm.Parser diff --git a/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Builder.hs b/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Builder.hs new file mode 100644 index 00000000..8849a91f --- /dev/null +++ b/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Builder.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Rendering logic + +module System.Nix.Derivation.ATerm.Builder + ( -- * Builder + buildTraditionalDerivation + , buildTraditionalDerivationWith + , buildFreeformDerivationOutput + , buildTraditionalDerivationInputs + ) where + +import Data.Map (Map) +import Data.Set (Set) +import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) +import Data.Vector (Vector) +import System.Nix.Derivation + ( FreeformDerivationOutput(..) + , FreeformDerivationOutputs + ) +import System.Nix.Derivation.Traditional +import System.Nix.StorePath +import System.Nix.OutputName + +import Data.Map qualified +import Data.Set qualified +import Data.Text qualified +import Data.Text.Lazy.Builder qualified +import Data.Vector qualified + +-- | Render a derivation as a `Builder` +buildTraditionalDerivation + :: StoreDir + -> TraditionalDerivation' TraditionalDerivationInputs FreeformDerivationOutputs + -> Builder +buildTraditionalDerivation sd = + buildTraditionalDerivationWith + (buildTraditionalDerivationInputs sd) + (\_ -> buildFreeformDerivationOutput sd) + +-- | Render a derivation as a `Builder` using custom +-- renderer for storePaths, texts, outputNames and derivation inputs/outputs +buildTraditionalDerivationWith + :: (drvInputs -> Builder) + -> (OutputName -> drvOutput -> Builder) + -> TraditionalDerivation' drvInputs (Map OutputName drvOutput) + -> Builder +buildTraditionalDerivationWith drvInputs drvOutput (TraditionalDerivation {..}) = + "Derive(" + <> mapOf keyValue0 anonOutputs + <> "," + <> drvInputs anonInputs + <> "," + <> string anonPlatform + <> "," + <> string anonBuilder + <> "," + <> vectorOf string anonArgs + <> "," + <> mapOf keyValue1 anonEnv + <> ")" + where + keyValue0 (key, output) = + "(" + <> buildOutputName key + <> "," + <> drvOutput key output + <> ")" + + keyValue1 (key, value) = + "(" + <> string key + <> "," + <> string value + <> ")" + +-- | Render a @FreeformDerivationOutput@ as a `Builder` using custom +-- renderer for storePaths +buildFreeformDerivationOutput + :: StoreDir + -> FreeformDerivationOutput + -> Builder +buildFreeformDerivationOutput storeDir = + ( \RawDerivationOutput {..} -> + string rawPath + <> "," + <> string rawMethodHashAlgo + <> "," + <> string rawHash + ) + . renderRawDerivationOutput storeDir + +-- | Render a @TraditionalDerivationInputs@ as a `Builder` using custom +-- renderer for storePaths and output names +buildTraditionalDerivationInputs + :: StoreDir + -> TraditionalDerivationInputs + -> Builder +buildTraditionalDerivationInputs storeDir (TraditionalDerivationInputs {..}) = + mapOf keyValue traditionalDrvs + <> "," + <> setOf (storePath storeDir) traditionalSrcs + where + keyValue (key, value) = + "(" + <> storePath storeDir key + <> "," + <> setOf buildOutputName value + <> ")" + +mapOf :: ((k, v) -> Builder) -> Map k v -> Builder +mapOf keyValue m = listOf keyValue (Data.Map.toList m) + +listOf :: (a -> Builder) -> [a] -> Builder +listOf _ [] = "[]" +listOf element (x:xs) = + "[" + <> element x + <> foldMap rest xs + <> "]" + where + rest y = "," <> element y + +setOf :: (a -> Builder) -> Set a -> Builder +setOf element xs = listOf element (Data.Set.toList xs) + +vectorOf :: (a -> Builder) -> Vector a -> Builder +vectorOf element xs = listOf element (Data.Vector.toList xs) + +string :: Text -> Builder +string = + Data.Text.Lazy.Builder.fromText + . (\input -> Data.Text.concat ["\"", Data.Text.concatMap escapeChar input, "\""]) + where + escapeChar :: Char -> Text + escapeChar '\"' = "\\\"" + escapeChar '\\' = "\\\\" + escapeChar '\n' = "\\n" + escapeChar '\r' = "\\r" + escapeChar '\t' = "\\t" + escapeChar c = Data.Text.singleton c + +buildOutputName :: OutputName -> Builder +buildOutputName = string . unStorePathName . unOutputName + +storePath :: StoreDir -> StorePath -> Builder +storePath sd = string . storePathToText sd diff --git a/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Parser.hs b/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Parser.hs new file mode 100644 index 00000000..b7ba9af5 --- /dev/null +++ b/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Parser.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +-- | Parsing logic + +module System.Nix.Derivation.ATerm.Parser + ( -- * Parser + parseTraditionalDerivation + , parseTraditionalDerivationWith + , parseFreeformDerivationOutput + , parseTraditionalDerivationInputs + , textParser + ) where + +import Data.Attoparsec.Text qualified +import Data.Attoparsec.Text.Lazy (Parser) +import Data.Attoparsec.Text.Lazy qualified +import Data.Map (Map) +import Data.Map qualified +import Data.Set (Set) +import Data.Set qualified +import Data.Text (Text) +import Data.Text qualified +import Data.Vector (Vector) +import Data.Vector qualified + +import System.Nix.Derivation + ( FreeformDerivationOutput(..) + , FreeformDerivationOutputs + ) +import System.Nix.Derivation.Traditional +import System.Nix.StorePath +import System.Nix.OutputName + +listOf :: Parser a -> Parser [a] +listOf element = do + "[" + es <- Data.Attoparsec.Text.Lazy.sepBy element "," + "]" + pure es + +-- | Parse a derivation +parseTraditionalDerivation + :: StoreDir + -> Parser (TraditionalDerivation' TraditionalDerivationInputs FreeformDerivationOutputs) +parseTraditionalDerivation sd = + parseTraditionalDerivationWith + (parseTraditionalDerivationInputs sd) + (\_ -> parseFreeformDerivationOutput sd) + +-- | Parse a derivation using custom +-- parsers for filepaths, texts, outputNames and derivation inputs/outputs +parseTraditionalDerivationWith + :: Parser drvInputs + -> (OutputName -> Parser drvOutput) + -> Parser (TraditionalDerivation' drvInputs (Map OutputName drvOutput)) +parseTraditionalDerivationWith parseInputs parseOutput = do + "Derive(" + + let keyValue0 = do + "(" + key <- outputNameParser + "," + drvOutput <- parseOutput key + ")" + return (key, drvOutput) + anonOutputs <- mapOf keyValue0 + + "," + + anonInputs <- parseInputs + + "," + + anonPlatform <- textParser + + "," + + anonBuilder <- textParser + + "," + + anonArgs <- vectorOf textParser + + "," + + let keyValue1 = do + "(" + key <- textParser + "," + value <- textParser + ")" + pure (key, value) + anonEnv <- mapOf keyValue1 + + ")" + + pure TraditionalDerivation {..} + +-- | Parse a derivation output +parseFreeformDerivationOutput :: StoreDir -> Parser FreeformDerivationOutput +parseFreeformDerivationOutput sd = do + rawPath <- textParser + "," + rawMethodHashAlgo <- textParser + "," + rawHash <- textParser + parseRawDerivationOutput sd $ RawDerivationOutput {..} + +-- | Parse a derivation inputs +parseTraditionalDerivationInputs :: StoreDir -> Parser TraditionalDerivationInputs +parseTraditionalDerivationInputs sd = do + traditionalDrvs <- mapOf $ do + "(" + key <- storePathParser sd + "," + value <- setOf outputNameParser + ")" + pure (key, value) + + "," + + traditionalSrcs <- setOf $ storePathParser sd + pure TraditionalDerivationInputs {..} + +textParser :: Parser Text +textParser = do + "\"" + + let predicate c = not (c == '"' || c == '\\') + + let loop = do + text0 <- Data.Attoparsec.Text.takeWhile predicate + + char0 <- Data.Attoparsec.Text.anyChar + + case char0 of + '"' -> do + pure [ text0 ] + + _ -> do + char1 <- Data.Attoparsec.Text.anyChar + + char2 <- case char1 of + 'n' -> pure '\n' + 'r' -> pure '\r' + 't' -> pure '\t' + _ -> pure char1 + + textChunks <- loop + + pure (text0 : Data.Text.singleton char2 : textChunks) + + Data.Text.concat <$> loop + +outputNameParser :: Parser OutputName +outputNameParser = do + n <- textParser + case mkOutputName n of + Left e -> fail $ show e -- TODO + Right sp -> pure sp + +storePathParser :: StoreDir -> Parser StorePath +storePathParser sd = do + f <- textParser + case System.Nix.StorePath.parsePathFromText sd f of + Left e -> fail $ show e -- TODO + Right sp -> pure sp + +setOf :: Ord a => Parser a -> Parser (Set a) +setOf element = do + es <- listOf element + pure (Data.Set.fromList es) + +vectorOf :: Parser a -> Parser (Vector a) +vectorOf element = do + es <- listOf element + pure (Data.Vector.fromList es) + +mapOf :: Ord k => Parser (k, v) -> Parser (Map k v) +mapOf keyValue = do + keyValues <- listOf keyValue + pure (Data.Map.fromList keyValues) diff --git a/hnix-store-aterm/src/System/Nix/Derivation/Traditional.hs b/hnix-store-aterm/src/System/Nix/Derivation/Traditional.hs new file mode 100644 index 00000000..f36a3383 --- /dev/null +++ b/hnix-store-aterm/src/System/Nix/Derivation/Traditional.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Shared types + +module System.Nix.Derivation.Traditional + ( RawDerivationOutput(..) + , parseRawDerivationOutput + , renderRawDerivationOutput + , TraditionalDerivation'(..) + , withName + , withoutName + , TraditionalDerivationInputs(..) + , inputsToTraditional + , inputsFromTraditional + ) where + + +import Control.DeepSeq (NFData(..)) +import Data.Constraint.Extras (Has(has)) +import Data.Dependent.Sum (DSum(..)) +import Data.Map (Map) +import Data.Map qualified +import Data.Map.Monoidal (MonoidalMap(..)) +import Data.Map.Monoidal qualified +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import Data.Some +import Data.Text (Text) +import Data.Text qualified +import Data.These (These(..)) +import Data.Vector (Vector) +import Data.Traversable (for) +import GHC.Generics (Generic, (:.:)(..)) + +import System.Nix.ContentAddress (ContentAddressMethod(..)) +import System.Nix.Derivation +import System.Nix.Hash +import System.Nix.OutputName (OutputName) +import System.Nix.StorePath + +-- | Useful for the ATerm format, and remote protocols that need the same parsing +-- If it won't for the protocol, we would just inline this into the ATerm code proper. +data RawDerivationOutput = RawDerivationOutput + { rawPath :: Text + , rawMethodHashAlgo :: Text + , rawHash :: Text + } deriving (Eq, Generic, Ord, Show) + +parseRawDerivationOutput + :: forall m + . MonadFail m + => StoreDir + -> RawDerivationOutput + -> m FreeformDerivationOutput +parseRawDerivationOutput storeDir (RawDerivationOutput {..}) = do + let onNonEmptyText :: Text -> (Text -> m a) -> m (Maybe a) + onNonEmptyText = flip $ \f -> \case + "" -> pure Nothing + t -> Just <$> f t + mPath <- onNonEmptyText rawPath $ \t -> case System.Nix.StorePath.parsePathFromText storeDir t of + Left e -> fail $ show e -- TODO + Right sp -> pure sp + mMethodHashAlgo <- onNonEmptyText rawMethodHashAlgo splitMethodHashAlgo + mHash0 <- onNonEmptyText rawHash pure + mContentAddressing <- case mMethodHashAlgo of + Nothing -> case mHash0 of + Nothing -> pure Nothing + Just _ -> fail "Hash without method and hash algo is not allowed" + Just (method, Some hashAlgo) -> do + mHash <- for mHash0 $ \hash0 -> + either fail pure $ has @NamedAlgo hashAlgo $ + decodeDigestWith NixBase32 hash0 + pure $ Just (method, hashAlgo :=> Comp1 mHash) + pure FreeformDerivationOutput { mPath, mContentAddressing } + +renderRawDerivationOutput + :: StoreDir + -> FreeformDerivationOutput + -> RawDerivationOutput +renderRawDerivationOutput storeDir (FreeformDerivationOutput {..}) = + RawDerivationOutput + { rawPath = fromMaybe "" $ storePathToText storeDir <$> mPath + , rawMethodHashAlgo = flip (maybe "") mContentAddressing $ \(method, hashAlgo :=> _) -> + buildMethodHashAlgo method $ Some hashAlgo + , rawHash = fromMaybe "" $ mContentAddressing >>= \(_, _ :=> Comp1 hash') -> + encodeDigestWith NixBase32 <$> hash' + } + +buildMethodHashAlgo :: ContentAddressMethod -> Some HashAlgo -> Text +buildMethodHashAlgo method hashAlgo = Data.Text.intercalate ":" $ + (case method of + ContentAddressMethod_NixArchive -> ["r"] + ContentAddressMethod_Text -> ["text"] + ContentAddressMethod_Flat -> []) + <> + [withSome hashAlgo algoToText] + +splitMethodHashAlgo :: MonadFail m => Text -> m (ContentAddressMethod, Some HashAlgo) +splitMethodHashAlgo methodHashAlgo = do + (method, hashAlgoS) <- case Data.Text.splitOn ":" methodHashAlgo of + ["r", hashAlgo] -> pure (ContentAddressMethod_NixArchive, hashAlgo) + ["text", hashAlgo] -> pure (ContentAddressMethod_Text, hashAlgo) + [hashAlgo] -> pure (ContentAddressMethod_Flat, hashAlgo) + _ -> fail "invalid number of colons or unknown CA method prefix" + hashAlgo <- either fail pure $ textToAlgo hashAlgoS + pure (method, hashAlgo) + +---------------- + +-- | The ATerm format doesn't include the derivation name. That must +-- instead be gotten out of band, e.g. from the Store Path. +data TraditionalDerivation' inputs outputs = TraditionalDerivation + { anonOutputs :: outputs + -- ^ Outputs produced by this derivation where keys are output names + , anonInputs :: inputs + -- ^ Inputs (sources and derivations) + , anonPlatform :: Text + -- ^ Platform required for this derivation + , anonBuilder :: Text + -- ^ Code to build the derivation, which can be a path or a builtin function + , anonArgs :: Vector Text + -- ^ Arguments passed to the executable used to build to derivation + , anonEnv :: Map Text Text + -- ^ Environment variables provided to the executable used to build the + -- derivation + } deriving (Eq, Generic, Ord, Show) + +instance (NFData inputs, NFData outputs) => NFData (TraditionalDerivation' inputs outputs) + +withName :: StorePathName -> TraditionalDerivation' inputs outputs -> Derivation' inputs outputs +withName name drv0 = Derivation + { name = name + , outputs = anonOutputs drv0 + , inputs = anonInputs drv0 + , platform = anonPlatform drv0 + , builder = anonBuilder drv0 + , args = anonArgs drv0 + , env = anonEnv drv0 + } + +withoutName :: Derivation' inputs outputs -> TraditionalDerivation' inputs outputs +withoutName drv0 = TraditionalDerivation + { anonOutputs = outputs drv0 + , anonPlatform = platform drv0 + , anonInputs = inputs drv0 + , anonBuilder = builder drv0 + , anonArgs = args drv0 + , anonEnv = env drv0 + } + +---------------- + +-- | Useful for the ATerm format +data TraditionalDerivationInputs = TraditionalDerivationInputs + { traditionalSrcs :: Set StorePath + -- ^ Inputs that are sources + , traditionalDrvs :: Map StorePath (Set OutputName) + -- ^ Inputs that are derivations where keys specify derivation paths and + -- values specify which output names are used by this derivation + } deriving (Eq, Generic, Ord, Show) + +instance NFData TraditionalDerivationInputs + +instance Semigroup TraditionalDerivationInputs where + TraditionalDerivationInputs x0 x1 <> TraditionalDerivationInputs y0 y1 = TraditionalDerivationInputs + (x0 <> y0) + (x1 <> y1) + +instance Monoid TraditionalDerivationInputs where + mempty = TraditionalDerivationInputs mempty mempty + +inputsToTraditional :: DerivationInputs -> Either StorePath TraditionalDerivationInputs +inputsToTraditional is = (\drvs -> TraditionalDerivationInputs + { traditionalSrcs = srcs is + , traditionalDrvs = drvs + }) <$> go (drvs is) + where + go = fmap getMonoidalMap + . Data.Map.Monoidal.traverseWithKey + (\storePath -> (\case + This os -> Right os + _ -> Left storePath -- TODO make better error, e.g. by partitioning the map + ) . unChildNode) + . unDerivedPathMap + +inputsFromTraditional :: TraditionalDerivationInputs -> DerivationInputs +inputsFromTraditional TraditionalDerivationInputs { traditionalSrcs, traditionalDrvs } = DerivationInputs + { srcs = traditionalSrcs + , drvs = DerivedPathMap $ Data.Map.Monoidal.fromList $ + fmap (fmap ChildNode . fmap This) (Data.Map.toList traditionalDrvs) + } diff --git a/hnix-store-core/tests/Derivation.hs b/hnix-store-aterm/tests/Derivation.hs similarity index 88% rename from hnix-store-core/tests/Derivation.hs rename to hnix-store-aterm/tests/Derivation.hs index 2a178e39..c7312999 100644 --- a/hnix-store-core/tests/Derivation.hs +++ b/hnix-store-aterm/tests/Derivation.hs @@ -1,4 +1,3 @@ - module Derivation where import Test.Tasty (TestTree, testGroup) @@ -7,9 +6,9 @@ import Test.Tasty.Golden (goldenVsFile) import System.Nix.Derivation (parseDerivation, buildDerivation) import Data.Default.Class (Default(def)) -import qualified Data.Attoparsec.Text.Lazy -import qualified Data.Text.Lazy.IO -import qualified Data.Text.Lazy.Builder +import Data.Attoparsec.Text.Lazy qualified +import Data.Text.Lazy.IO qualified +import Data.Text.Lazy.Builder qualified processDerivation :: FilePath -> FilePath -> IO () processDerivation source dest = do diff --git a/hnix-store-aterm/tests/DerivationSpec.hs b/hnix-store-aterm/tests/DerivationSpec.hs new file mode 100644 index 00000000..05867220 --- /dev/null +++ b/hnix-store-aterm/tests/DerivationSpec.hs @@ -0,0 +1,27 @@ +module DerivationSpec where + +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (xprop) +import Test.Hspec.Nix (roundtrips) + +import System.Nix.Arbitrary () +import System.Nix.Derivation (parseDerivation, buildDerivation) + +import Data.Attoparsec.Text qualified +import Data.Text.Lazy qualified +import Data.Text.Lazy.Builder qualified + +-- TODO(srk): this won't roundtrip as Arbitrary Text +-- contains wild stuff like control characters and UTF8 sequences. +-- Either fix in hnix-store-aterm or use wrapper type +-- (but we use System.Nix.Derivation.ATerm.textParser so we need Text for now) +spec :: Spec +spec = do + describe "Derivation" $ do + xprop "roundtrips via Text" $ \sd -> + roundtrips + ( Data.Text.Lazy.toStrict + . Data.Text.Lazy.Builder.toLazyText + . buildDerivation sd + ) + (Data.Attoparsec.Text.parseOnly (parseDerivation sd)) diff --git a/hnix-store-aterm/tests/Example.hs b/hnix-store-aterm/tests/Example.hs new file mode 100644 index 00000000..59fb4ac0 --- /dev/null +++ b/hnix-store-aterm/tests/Example.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Attoparsec.Text.Lazy qualified +import Data.Text.Lazy.Builder qualified +import Data.Text.Lazy.IO qualified +import Data.Attoparsec.Text.Lazy (Result(..)) + +import System.Nix.StorePath +import System.Nix.Derivation.ATerm qualified + +main :: IO () +main = do + let storeDir = StoreDir "/nix/store" + text0 <- Data.Text.Lazy.IO.readFile "tests/example0.drv" + derivation <- + case + Data.Attoparsec.Text.Lazy.parse + (System.Nix.Derivation.ATerm.parseTraditionalDerivation storeDir) + text0 + of + Fail _ _ string -> fail string + Done _ derivation -> return derivation + let builder = System.Nix.Derivation.ATerm.buildTraditionalDerivation storeDir derivation + let text1 = Data.Text.Lazy.Builder.toLazyText builder + if text0 == text1 + then return () + else fail "Parsing and rendering the example derivation does not round-trip" diff --git a/hnix-store-aterm/tests/Property.hs b/hnix-store-aterm/tests/Property.hs new file mode 100644 index 00000000..f0727253 --- /dev/null +++ b/hnix-store-aterm/tests/Property.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +-- due to recent generic-arbitrary +{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main where + +import Prelude hiding (FilePath, either) + +import Data.Attoparsec.Text.Lazy qualified +import Data.Text.Lazy.Builder qualified +import Test.QuickCheck (Arbitrary) +import Test.QuickCheck qualified +import Test.QuickCheck.Property (failed, succeeded, Result(..)) +import Test.QuickCheck.Arbitrary.Generic (Arg, GenericArbitrary(..)) + +import System.Nix.StorePath +import System.Nix.Arbitrary.Derivation () +import System.Nix.Derivation +import System.Nix.Derivation.ATerm qualified +import System.Nix.Derivation.Traditional + +deriving via GenericArbitrary TraditionalDerivationInputs + instance Arbitrary TraditionalDerivationInputs + +deriving via GenericArbitrary (TraditionalDerivation' inputs outputs) + instance + ( Arbitrary inputs + , Arbitrary outputs + , Arg (TraditionalDerivation' inputs outputs) inputs + , Arg (TraditionalDerivation' inputs outputs) outputs + ) => Arbitrary (TraditionalDerivation' inputs outputs) + +property + :: StoreDir + -> TraditionalDerivation' + TraditionalDerivationInputs + FreeformDerivationOutputs + -> Result +property storeDir derivation0 = + if either == expected + then succeeded + else failed { reason = unlines ["", show either, show expected] } + where + builder = System.Nix.Derivation.ATerm.buildTraditionalDerivation storeDir derivation0 + + text = Data.Text.Lazy.Builder.toLazyText builder + + result = + Data.Attoparsec.Text.Lazy.parse + (System.Nix.Derivation.ATerm.parseTraditionalDerivation storeDir) + text + + either, expected :: Either String (TraditionalDerivation' TraditionalDerivationInputs FreeformDerivationOutputs) + + either = + Data.Attoparsec.Text.Lazy.eitherResult result + + expected = Right derivation0 + +main :: IO () +main = Test.QuickCheck.quickCheck property diff --git a/hnix-store-core/tests/samples/example0.actual b/hnix-store-aterm/tests/example0.drv similarity index 100% rename from hnix-store-core/tests/samples/example0.actual rename to hnix-store-aterm/tests/example0.drv diff --git a/hnix-store-core/tests/samples/example1.actual b/hnix-store-aterm/tests/example1.drv similarity index 100% rename from hnix-store-core/tests/samples/example1.actual rename to hnix-store-aterm/tests/example1.drv diff --git a/hnix-store-core/hnix-store-core.cabal b/hnix-store-core/hnix-store-core.cabal index 3fd12e39..8582895c 100644 --- a/hnix-store-core/hnix-store-core.cabal +++ b/hnix-store-core/hnix-store-core.cabal @@ -17,40 +17,40 @@ extra-doc-files: CHANGELOG.md extra-source-files: README.md - , tests/samples/example0.drv - , tests/samples/example1.drv common commons ghc-options: -Wall default-extensions: ConstraintKinds + , BangPatterns , DataKinds - , DeriveGeneric , DeriveDataTypeable - , DeriveFunctor , DeriveFoldable - , DeriveTraversable + , DeriveFunctor + , DeriveGeneric , DeriveLift + , DeriveTraversable , DerivingStrategies , DerivingVia , ExistentialQuantification + , ImportQualifiedPost , FlexibleContexts , FlexibleInstances , GADTs + , ImportQualifiedPost + , InstanceSigs + , KindSignatures + , LambdaCase + , MultiParamTypeClasses + , MultiWayIf + , RecordWildCards , ScopedTypeVariables , StandaloneDeriving - , RecordWildCards + , TupleSections , TypeApplications , TypeFamilies , TypeOperators , TypeSynonymInstances - , InstanceSigs - , KindSignatures - , MultiParamTypeClasses - , MultiWayIf - , TupleSections - , LambdaCase - , BangPatterns , ViewPatterns default-language: Haskell2010 @@ -72,6 +72,7 @@ library , System.Nix.Signature , System.Nix.Store.Types , System.Nix.StorePath + , System.Nix.StorePath.ContentAddressed , System.Nix.StorePath.Metadata build-depends: base >=4.12 && <5 @@ -79,18 +80,21 @@ library , base16-bytestring >= 1.0 , base64-bytestring >= 1.2.1 , bytestring - , containers , constraints-extras + , containers , crypton , data-default-class + , deepseq , dependent-sum > 0.7 , dependent-sum-template >= 0.2.0.1 && < 0.3 + , dependent-monoidal-map , filepath , hashable -- Required for crypton low-level type convertion , memory - , nix-derivation >= 1.1.1 && <2 + , monoidal-containers , some > 1.0.5 && < 2 + , these , time , text , unordered-containers @@ -102,7 +106,6 @@ test-suite core type: exitcode-stdio-1.0 main-is: Driver.hs other-modules: - Derivation Fingerprint Hash Signature diff --git a/hnix-store-core/src/System/Nix/Base.hs b/hnix-store-core/src/System/Nix/Base.hs index 37a9c687..bff1bd10 100644 --- a/hnix-store-core/src/System/Nix/Base.hs +++ b/hnix-store-core/src/System/Nix/Base.hs @@ -8,11 +8,11 @@ import Data.ByteString (ByteString) import Data.Text (Text) import GHC.Generics (Generic) -import qualified Data.Text.Encoding -import qualified Data.ByteString.Base16 -import qualified Data.ByteString.Base64 +import Data.Text.Encoding qualified +import Data.ByteString.Base16 qualified +import Data.ByteString.Base64 qualified -import qualified System.Nix.Base32 -- Nix has own Base32 encoding +import System.Nix.Base32 qualified -- Nix has own Base32 encoding -- | Constructors to indicate the base encodings data BaseEncoding diff --git a/hnix-store-core/src/System/Nix/Base32.hs b/hnix-store-core/src/System/Nix/Base32.hs index cb9e54f4..4cae649e 100644 --- a/hnix-store-core/src/System/Nix/Base32.hs +++ b/hnix-store-core/src/System/Nix/Base32.hs @@ -12,15 +12,15 @@ import Data.Text (Text) import Data.Vector (Vector) import Data.Word (Word8) -import qualified Data.Bits -import qualified Data.Bool -import qualified Data.ByteString -import qualified Data.ByteString.Char8 -import qualified Data.List -import qualified Data.Maybe -import qualified Data.Text -import qualified Data.Vector -import qualified Numeric +import Data.Bits qualified +import Data.Bool qualified +import Data.ByteString qualified +import Data.ByteString.Char8 qualified +import Data.List qualified +import Data.Maybe qualified +import Data.Text qualified +import Data.Vector qualified +import Numeric qualified -- omitted: E O U T digits32 :: Vector Char diff --git a/hnix-store-core/src/System/Nix/Build.hs b/hnix-store-core/src/System/Nix/Build.hs index 17e484cd..dbfe755f 100644 --- a/hnix-store-core/src/System/Nix/Build.hs +++ b/hnix-store-core/src/System/Nix/Build.hs @@ -15,7 +15,7 @@ import Data.Text (Text) import GHC.Generics (Generic) import System.Nix.OutputName (OutputName) -import System.Nix.Realisation (DerivationOutput, Realisation) +import System.Nix.Realisation (BuildTraceKey, Realisation) -- | Mode of the build operation -- Keep the order of these Enums to match enums from reference implementations @@ -59,7 +59,7 @@ data BuildResult = BuildResult -- ^ Start time of this build (since 1.29) , buildResultStopTime :: Maybe UTCTime -- ^ Stop time of this build (since 1.29) - , buildResultBuiltOutputs :: Maybe (Map (DerivationOutput OutputName) Realisation) + , buildResultBuiltOutputs :: Maybe (Map (BuildTraceKey OutputName) Realisation) -- ^ Mapping of the output names to @Realisation@s (since 1.28) -- (paths with additional info and their dependencies) } diff --git a/hnix-store-core/src/System/Nix/ContentAddress.hs b/hnix-store-core/src/System/Nix/ContentAddress.hs index 33541ee2..71747672 100644 --- a/hnix-store-core/src/System/Nix/ContentAddress.hs +++ b/hnix-store-core/src/System/Nix/ContentAddress.hs @@ -10,6 +10,7 @@ module System.Nix.ContentAddress ( ) where import Control.Applicative +import Control.DeepSeq (NFData) import Crypto.Hash (Digest) import Data.Attoparsec.Text (Parser) import Data.Dependent.Sum (DSum) @@ -18,10 +19,10 @@ import Data.Text.Lazy.Builder (Builder) import GHC.Generics (Generic) import System.Nix.Hash (HashAlgo) -import qualified Data.Attoparsec.Text -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder -import qualified System.Nix.Hash +import Data.Attoparsec.Text qualified +import Data.Text.Lazy qualified +import Data.Text.Lazy.Builder qualified +import System.Nix.Hash qualified data ContentAddressMethod = ContentAddressMethod_Flat @@ -32,6 +33,8 @@ data ContentAddressMethod -- file contents. deriving (Eq, Generic, Ord, Show) +instance NFData ContentAddressMethod + -- | An address for a content-addressable store path, i.e. one whose -- store path hash is purely a function of its contents (as opposed to -- paths that are derivation outputs, whose hashes are a function of diff --git a/hnix-store-core/src/System/Nix/Derivation.hs b/hnix-store-core/src/System/Nix/Derivation.hs index 0feb2ecf..e6f6dc73 100644 --- a/hnix-store-core/src/System/Nix/Derivation.hs +++ b/hnix-store-core/src/System/Nix/Derivation.hs @@ -1,45 +1,364 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Shared types + module System.Nix.Derivation - ( parseDerivation - , buildDerivation - -- Re-exports - , Derivation(..) - , DerivationOutput(..) - ) where - -import Data.Attoparsec.Text.Lazy (Parser) + ( -- * Types + Derivation'(..) + , Derivation + , BasicDerivation + + , DerivationType(..) + , DerivationOutputs + , InputAddressedDerivationOutput(..) + , FixedDerivationOutput(..) + , ContentAddressedDerivationOutput(..) + + , FreeformDerivationOutput(..) + , FreeformDerivationOutputs + , toSpecificOutput + , fromSpecificOutput + , toSpecificOutputs + , fromSpecificOutputs + + , DerivationInputs(..) + , derivationInputsFromSingleDerivedPath + , derivationInputsToDerivedPaths + + , DerivedPathMap(..) + , ChildNode(..) + , derivedPathMapFromSingleDerivedPathBuilt + , derivedPathMapToSet + ) where + +import Control.Monad (when) +import Control.DeepSeq (NFData(..)) +import Crypto.Hash (Digest) +import Data.Constraint.Extras +import Data.Constraint.Extras.TH (deriveArgDict) +import Data.Dependent.Map.Monoidal qualified as MonoidalDMap +import Data.Dependent.Sum (DSum(..)) +import Data.Functor.Identity +import Data.GADT.Compare.TH +import Data.GADT.Show.TH +import Data.GADT.DeepSeq (GNFData(..)) +import Data.Kind +import Data.Map (Map) +import Data.Map qualified +import Data.Map.Monoidal (MonoidalMap) +import Data.Map.Monoidal qualified +import Data.Set (Set) +import Data.Set qualified +import Data.Some (Some(..)) import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) - -import Nix.Derivation (Derivation(..), DerivationOutput(..)) -import System.Nix.StorePath (StoreDir, StorePath) - -import qualified Data.Attoparsec.Text.Lazy -import qualified Data.Text -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder - -import qualified Nix.Derivation -import qualified System.Nix.StorePath - -parseDerivation :: StoreDir -> Parser (Derivation StorePath Text) -parseDerivation expectedRoot = - Nix.Derivation.parseDerivationWith - pathParser - Nix.Derivation.textParser - where - pathParser = do - text <- Nix.Derivation.textParser - case Data.Attoparsec.Text.Lazy.parseOnly - (System.Nix.StorePath.pathParser expectedRoot) - (Data.Text.Lazy.fromStrict text) - of - Right p -> pure p - Left e -> fail e - -buildDerivation :: StoreDir -> Derivation StorePath Text -> Builder -buildDerivation storeDir = - Nix.Derivation.buildDerivationWith - (string . System.Nix.StorePath.storePathToText storeDir) - string - where - string = Data.Text.Lazy.Builder.fromText . Data.Text.pack . show +import Data.These (These(..), fromThese) +import Data.Vector (Vector) +import GHC.Generics (Generic, (:.:)(..)) + +import System.Nix.ContentAddress (ContentAddressMethod) +import System.Nix.DerivedPath (SingleDerivedPath(..)) +import System.Nix.Hash (HashAlgo) +import System.Nix.OutputName (OutputName, outputStoreObjectName) +import System.Nix.StorePath (StoreDir, StorePath, StorePathName) +import System.Nix.StorePath.ContentAddressed + +-- | The type of the derivation +data DerivationType :: Type -> Type where + + -- | The outputs are input-addressed. + DerivationType_InputAddressing :: DerivationType InputAddressedDerivationOutput + + -- | The outputs are content-addressed, and the content addresses are + -- "fixed", i.e. required to be specific values (or the build fails) + -- by the derivation itself. + DerivationType_Fixed :: DerivationType FixedDerivationOutput + + -- | The outputs are content-addressed, and the content addresses are + -- "floating", i.e. they are not required to be a specific value like + -- in the "fixed" case. + DerivationType_ContentAddressing :: DerivationType ContentAddressedDerivationOutput + +---------------- + +type DerivationOutputs = DSum DerivationType (Map OutputName) + +-- | An output of a Nix derivation +data InputAddressedDerivationOutput = InputAddressedDerivationOutput + { iaPath :: StorePath + -- ^ Path where the output will be saved + } + deriving (Eq, Generic, Ord, Show) + +instance NFData InputAddressedDerivationOutput + +data FixedDerivationOutput = FixedDerivationOutput + { fMethod :: ContentAddressMethod + -- ^ How this output is serialized into a hash / what sort of CA + -- store path is used. + , fHash :: DSum HashAlgo Digest + -- ^ Expected hash of this output + } + deriving (Eq, Generic, Ord, Show) + +instance NFData FixedDerivationOutput + +data ContentAddressedDerivationOutput = ContentAddressedDerivationOutput + { caMethod :: ContentAddressMethod + -- ^ How this output is serialized into a hash / what sort of CA + -- store path is used. + , caHashAlgo :: Some HashAlgo + -- ^ What sort of hash function is used with the above + -- content-addressing method to produce the (content-addressed) + -- store path we'll use for the output. + } + deriving (Eq, Generic, Ord, Show) + +instance NFData ContentAddressedDerivationOutput + +---------------- + +-- | TODO this should go in `dependent-sum` +instance (GNFData k, Has' NFData k v) => NFData (DSum k v) where + rnf (x :=> y) = grnf x `seq` has' @NFData @v x (rnf y) + +-- | TODO this needs a home +instance GNFData Digest where + grnf = rnf + +---------------- + +deriveGEq ''DerivationType +deriveGCompare ''DerivationType +deriveGShow ''DerivationType +deriveArgDict ''DerivationType + +---------------- + +data Derivation' inputs outputs = Derivation + { name :: StorePathName + -- ^ Name of the derivation, needed for calculating output paths + , outputs :: outputs + -- ^ Outputs produced by this derivation where keys are output names + , inputs :: inputs + -- ^ Inputs (sources and derivations) + , platform :: Text + -- ^ Platform required for this derivation + , builder :: Text + -- ^ Code to build the derivation, which can be a path or a builtin function + , args :: Vector Text + -- ^ Arguments passed to the executable used to build to derivation + , env :: Map Text Text + -- ^ Environment variables provided to the executable used to build the + -- derivation + } deriving (Eq, Generic, Ord, Show) + +instance (NFData inputs, NFData output) => NFData (Derivation' inputs output) + +-- | A regular Nix derivation +type Derivation = Derivation' DerivationInputs DerivationOutputs + +-- | A Nix derivation that only depends on other store objects directly, +-- not (the outputs of) other derivations +type BasicDerivation = Derivation' (Set StorePath) DerivationOutputs + +---------------- + +data DerivationInputs = DerivationInputs + { srcs :: Set StorePath + -- ^ Inputs that are sources + , drvs :: DerivedPathMap + -- ^ Inputs that are derivations where keys specify derivation paths and + -- values specify which output names are used by this derivation + } deriving (Eq, Generic, Ord, Show) + +instance NFData DerivationInputs + +instance Semigroup DerivationInputs where + DerivationInputs x0 x1 <> DerivationInputs y0 y1 = DerivationInputs + (x0 <> y0) + (x1 <> y1) + +instance Monoid DerivationInputs where + mempty = DerivationInputs mempty mempty + +derivationInputsFromSingleDerivedPath :: SingleDerivedPath -> DerivationInputs +derivationInputsFromSingleDerivedPath = \case + SingleDerivedPath_Opaque storePath -> DerivationInputs + { srcs = Data.Set.singleton storePath + , drvs = mempty + } + SingleDerivedPath_Built drvDPath outputName -> DerivationInputs + { srcs = mempty + , drvs = derivedPathMapFromSingleDerivedPathBuilt drvDPath outputName + } + +derivationInputsToDerivedPaths :: DerivationInputs -> Set SingleDerivedPath +derivationInputsToDerivedPaths inputs = + Data.Set.mapMonotonic SingleDerivedPath_Opaque (srcs inputs) + <> + derivedPathMapToSet (drvs inputs) + +-- | A recursive map to handle dependencies on dynamic derivations in +-- addition to static ones +newtype DerivedPathMap = DerivedPathMap + { unDerivedPathMap :: MonoidalMap StorePath ChildNode + } deriving (Eq, Generic, Ord, Show) + deriving newtype (Semigroup, Monoid) + +instance NFData DerivedPathMap + +newtype ChildNode = ChildNode + { unChildNode :: These (Set OutputName) (MonoidalMap OutputName ChildNode) + } deriving (Eq, Generic, Ord, Show) + deriving newtype (Semigroup) + +instance NFData ChildNode + +derivedPathMapFromSingleDerivedPathBuilt :: SingleDerivedPath -> OutputName -> DerivedPathMap +derivedPathMapFromSingleDerivedPathBuilt drvDPath outputName0 = go drvDPath $ ChildNode $ This $ Data.Set.singleton outputName0 + where + go :: SingleDerivedPath -> ChildNode -> DerivedPathMap + go d child = case d of + SingleDerivedPath_Opaque drvPath -> DerivedPathMap $ Data.Map.Monoidal.singleton drvPath child + SingleDerivedPath_Built nestedPath nestedOutputName -> go nestedPath $ ChildNode $ That $ Data.Map.Monoidal.singleton nestedOutputName child + +derivedPathMapToSet :: DerivedPathMap -> Set SingleDerivedPath +derivedPathMapToSet (DerivedPathMap m) = Data.Set.unions $ fmap + (\(p, c) -> go (SingleDerivedPath_Opaque p) c) + (Data.Map.Monoidal.toList m) + where + go :: SingleDerivedPath -> ChildNode -> Set SingleDerivedPath + go accum (ChildNode child) = + Data.Set.mapMonotonic (SingleDerivedPath_Built accum) shallows + <> + Data.Set.unions (fmap + (\(outputName, child') -> go (SingleDerivedPath_Built accum outputName) child') + $ Data.Map.Monoidal.toList deeps) + where (shallows, deeps) = fromThese mempty mempty child + +---------------- + +-- | This single data type can represent all types of derivation +-- outputs, but allows for many illegal states. This is here as a +-- simpler intermediate data type to aid with derivation parsing (both +-- JSON and ATerm). +data FreeformDerivationOutput + = FreeformDerivationOutput + { mPath :: Maybe StorePath + -- ^ Optional: Path where the output will be saved + , mContentAddressing :: Maybe (ContentAddressMethod, DSum HashAlgo (Maybe :.: Digest)) + -- ^ Optional: How this output is serialized into a hash / what sort of CA + -- store path is used. + -- + -- Inner Optional: Expected hash algorithm and also possibly hash + -- for this output. + } + deriving (Eq, Generic, Ord, Show) + +instance NFData FreeformDerivationOutput + +-- | TODO upstream +instance NFData (f (g a)) => NFData ((f :.: g) a) where + rnf (Comp1 x) = rnf x + +type FreeformDerivationOutputs = Map OutputName FreeformDerivationOutput + +-- | Convert a 'FreeformDerivationOutput' to a derivation type and +-- output +toSpecificOutput + :: forall m + . MonadFail m + => StoreDir + -> StorePathName + -> OutputName + -> FreeformDerivationOutput + -> m (DSum DerivationType Identity) +toSpecificOutput storeDir drvName outputName = \case + FreeformDerivationOutput + { mPath = Just path + , mContentAddressing = Nothing + } -> pure $ DerivationType_InputAddressing :=> Identity (InputAddressedDerivationOutput path) + FreeformDerivationOutput + { mPath = Just path + , mContentAddressing = Just (method, algo :=> Comp1 (Just hash)) + } -> do + fullOutputName <- either (fail . show) pure $ + outputStoreObjectName drvName outputName + let hash' = algo :=> hash + let expectedPath = makeFixedOutputPath storeDir method hash' mempty fullOutputName + when (path /= expectedPath) $ + fail "fixed output path does not match info" + pure $ DerivationType_Fixed :=> Identity (FixedDerivationOutput method hash') + FreeformDerivationOutput + { mPath = Nothing + , mContentAddressing = Just (method, algo :=> Comp1 Nothing) + } -> pure $ DerivationType_ContentAddressing :=> Identity (ContentAddressedDerivationOutput method (Some algo)) + _ -> fail "Invalid combination of path/method/hash being present or absent" + +-- | Convert a derivation type and output to a 'FreeformDerivationOutput' +fromSpecificOutput + :: StoreDir + -> StorePathName + -> OutputName + -> DSum DerivationType Identity + -> FreeformDerivationOutput +fromSpecificOutput storeDir drvName outputName (ty :=> Identity output) = case ty of + DerivationType_InputAddressing -> + case output of + InputAddressedDerivationOutput { iaPath } -> + FreeformDerivationOutput + { mPath = Just iaPath + , mContentAddressing = Nothing + } + DerivationType_Fixed -> + case output of + FixedDerivationOutput { fMethod, fHash = hash'@(algo :=> hash) } -> + FreeformDerivationOutput + { mPath = Just $ makeFixedOutputPath storeDir fMethod hash' mempty + $ either (error . show) id -- TODO do better + $ outputStoreObjectName drvName outputName + , mContentAddressing = Just (fMethod, algo :=> Comp1 (Just hash)) + } + DerivationType_ContentAddressing -> + case output of + ContentAddressedDerivationOutput { caMethod, caHashAlgo = Some algo } -> + FreeformDerivationOutput + { mPath = Nothing + , mContentAddressing = Just (caMethod, algo :=> Comp1 Nothing) + } + +-- | Convert a map of 'FreeformDerivationOutput' to 'DerivationOutputs' +toSpecificOutputs + :: forall m + . MonadFail m + => StoreDir + -> StorePathName + -> FreeformDerivationOutputs + -> m DerivationOutputs +toSpecificOutputs storeDir drvName outputs = do + -- Traverse and convert each output + converted <- Data.Map.traverseWithKey (toSpecificOutput storeDir drvName) outputs + -- Group outputs by their derivation type + let grouped = foldMap + (\(name, ty :=> Identity output) -> MonoidalDMap.singleton ty $ Data.Map.singleton name output) + (Data.Map.toList converted) + case MonoidalDMap.toList grouped of + [res] -> pure res + _ -> fail "derivation outputs did not agree on derivation type" + +-- | Convert a map of specific derivation outputs to a 'FreeformDerivationOutputs' +fromSpecificOutputs + :: StoreDir + -> StorePathName + -> DerivationOutputs + -> FreeformDerivationOutputs +fromSpecificOutputs storeDir drvName (drvType :=> outputs) = + flip Data.Map.mapWithKey outputs $ \outputName output -> + fromSpecificOutput storeDir drvName outputName $ drvType :=> Identity output diff --git a/hnix-store-core/src/System/Nix/DerivedPath.hs b/hnix-store-core/src/System/Nix/DerivedPath.hs index 16c8f93f..13dc85da 100644 --- a/hnix-store-core/src/System/Nix/DerivedPath.hs +++ b/hnix-store-core/src/System/Nix/DerivedPath.hs @@ -2,6 +2,9 @@ module System.Nix.DerivedPath ( OutputsSpec(..) + , SingleDerivedPath(..) + , parseSingleDerivedPath + , singleDerivedPathToText , DerivedPath(..) , ParseOutputsError(..) , parseOutputsSpec @@ -16,12 +19,13 @@ import Data.Text (Text) import System.Nix.OutputName (OutputName, InvalidNameError) import System.Nix.StorePath (StoreDir(..), StorePath, InvalidPathError) -import qualified Data.Bifunctor -import qualified Data.ByteString.Char8 -import qualified Data.Set -import qualified Data.Text -import qualified System.Nix.OutputName -import qualified System.Nix.StorePath +import Data.Bifunctor qualified +import Data.ByteString.Char8 qualified +import Data.Set qualified +import Data.List qualified +import Data.Text qualified +import System.Nix.OutputName qualified +import System.Nix.StorePath qualified data OutputsSpec = OutputsSpec_All @@ -30,11 +34,19 @@ data OutputsSpec = -- ^ Set of specific outputs deriving (Eq, Generic, Ord, Show) +data SingleDerivedPath = + SingleDerivedPath_Opaque StorePath + -- ^ Fully evaluated store path that can't be built + -- but can be fetched + | SingleDerivedPath_Built SingleDerivedPath OutputName + -- ^ Derivation path and the output built from it + deriving (Eq, Generic, Ord, Show) + data DerivedPath = DerivedPath_Opaque StorePath -- ^ Fully evaluated store path that can't be built -- but can be fetched - | DerivedPath_Built StorePath OutputsSpec + | DerivedPath_Built SingleDerivedPath OutputsSpec -- ^ Derivation path and the outputs built from it deriving (Eq, Generic, Ord, Show) @@ -45,15 +57,19 @@ data ParseOutputsError = | ParseOutputsError_NoPrefix StoreDir Text deriving (Eq, Ord, Show) +parseOutputName :: Text -> Either ParseOutputsError OutputName +parseOutputName = + ( Data.Bifunctor.first + ParseOutputsError_InvalidName + . System.Nix.OutputName.mkOutputName + ) + parseOutputsSpec :: Text -> Either ParseOutputsError OutputsSpec parseOutputsSpec t | t == "*" = Right OutputsSpec_All | otherwise = do names <- mapM - ( Data.Bifunctor.first - ParseOutputsError_InvalidName - . System.Nix.OutputName.mkOutputName - ) + parseOutputName (Data.Text.splitOn "," t) if null names then Left ParseOutputsError_NoNames @@ -65,10 +81,36 @@ outputsSpecToText = \case OutputsSpec_Names ns -> Data.Text.intercalate "," - (fmap System.Nix.OutputName.unOutputName + (fmap (System.Nix.StorePath.unStorePathName . System.Nix.OutputName.unOutputName) (Data.Set.toList ns) ) +parseSingleDerivedPath + :: StoreDir + -> Text + -> Either ParseOutputsError SingleDerivedPath +parseSingleDerivedPath root@(StoreDir sd) path = + let -- We need to do a bit more legwork for case + -- when StoreDir contains '!' + -- which is generated by its Arbitrary instance + textRoot = Data.Text.pack + $ Data.ByteString.Char8.unpack sd + + in case Data.Text.stripPrefix textRoot path of + Nothing -> Left $ ParseOutputsError_NoPrefix root path + Just woRoot -> + case Data.Text.splitOn "!" woRoot of + [] -> error "internal error, this function should return NonEmpty" + (pathNoPrefix : outputs) -> Data.List.foldl' + (liftA2 SingleDerivedPath_Built) + (SingleDerivedPath_Opaque + <$> (convertError + $ System.Nix.StorePath.parsePathFromText + root + (textRoot <> pathNoPrefix) + )) + (parseOutputName <$> outputs) + parseDerivedPath :: StoreDir -> Text @@ -83,8 +125,8 @@ parseDerivedPath root@(StoreDir sd) path = in case Data.Text.stripPrefix textRoot path of Nothing -> Left $ ParseOutputsError_NoPrefix root path Just woRoot -> - case Data.Text.breakOn "!" woRoot of - (pathNoPrefix, r) -> + case Data.Text.breakOnEnd "!" woRoot of + (r, suffix) -> if Data.Text.null r then DerivedPath_Opaque <$> (convertError @@ -93,23 +135,30 @@ parseDerivedPath root@(StoreDir sd) path = path ) else DerivedPath_Built - <$> (convertError - $ System.Nix.StorePath.parsePathFromText - root - (textRoot <> pathNoPrefix) - ) - <*> parseOutputsSpec (Data.Text.drop (Data.Text.length "!") r) - where - convertError - :: Either InvalidPathError a - -> Either ParseOutputsError a - convertError = Data.Bifunctor.first ParseOutputsError_InvalidPath + <$> parseSingleDerivedPath + root + (textRoot <> Data.Text.dropEnd (Data.Text.length "!") r) + <*> parseOutputsSpec suffix + +convertError + :: Either InvalidPathError a + -> Either ParseOutputsError a +convertError = Data.Bifunctor.first ParseOutputsError_InvalidPath + +singleDerivedPathToText :: StoreDir -> SingleDerivedPath -> Text +singleDerivedPathToText root = \case + SingleDerivedPath_Opaque p -> + System.Nix.StorePath.storePathToText root p + SingleDerivedPath_Built p o -> + singleDerivedPathToText root p + <> "!" + <> System.Nix.StorePath.unStorePathName (System.Nix.OutputName.unOutputName o) derivedPathToText :: StoreDir -> DerivedPath -> Text derivedPathToText root = \case DerivedPath_Opaque p -> System.Nix.StorePath.storePathToText root p DerivedPath_Built p os -> - System.Nix.StorePath.storePathToText root p + singleDerivedPathToText root p <> "!" <> outputsSpecToText os diff --git a/hnix-store-core/src/System/Nix/Fingerprint.hs b/hnix-store-core/src/System/Nix/Fingerprint.hs index 4eb7f309..6ba71edc 100644 --- a/hnix-store-core/src/System/Nix/Fingerprint.hs +++ b/hnix-store-core/src/System/Nix/Fingerprint.hs @@ -20,8 +20,8 @@ import System.Nix.Hash (HashAlgo, algoDigestBuilder) import System.Nix.StorePath import System.Nix.StorePath.Metadata (Metadata(..)) -import qualified Data.HashSet as HashSet -import qualified Data.Text as Text +import Data.HashSet qualified as HashSet +import Data.Text qualified as Text -- | Produce the message signed by a NAR signature metadataFingerprint :: StoreDir -> StorePath -> Metadata StorePath -> Text diff --git a/hnix-store-core/src/System/Nix/Hash.hs b/hnix-store-core/src/System/Nix/Hash.hs index 79fb7fd6..037f6d1b 100644 --- a/hnix-store-core/src/System/Nix/Hash.hs +++ b/hnix-store-core/src/System/Nix/Hash.hs @@ -25,12 +25,14 @@ module System.Nix.Hash , digestBuilder ) where +import Control.DeepSeq (NFData(..)) import Crypto.Hash (Digest, HashAlgorithm, MD5(..), SHA1(..), SHA256(..), SHA512(..)) import Data.ByteString (ByteString) import Data.Constraint.Extras (Has(has)) import Data.Constraint.Extras.TH (deriveArgDict) import Data.Dependent.Sum (DSum((:=>))) import Data.GADT.Compare.TH (deriveGEq, deriveGCompare) +import Data.GADT.DeepSeq (GNFData(..)) import Data.GADT.Show.TH (deriveGShow) import Data.Kind (Type) import Data.Some (Some(Some)) @@ -38,12 +40,12 @@ import Data.Text (Text) import Data.Text.Lazy.Builder (Builder) import System.Nix.Base (BaseEncoding(..)) -import qualified Crypto.Hash -import qualified Data.ByteArray -import qualified Data.Text -import qualified Data.Text.Lazy.Builder -import qualified System.Nix.Base -import qualified System.Nix.Hash.Truncation +import Crypto.Hash qualified +import Data.ByteArray qualified +import Data.Text qualified +import Data.Text.Lazy.Builder qualified +import System.Nix.Base qualified +import System.Nix.Hash.Truncation qualified -- | A 'HashAlgorithm' with a canonical name, for serialization -- purposes (e.g. SRI hashes) @@ -73,6 +75,16 @@ deriveGCompare ''HashAlgo deriveGShow ''HashAlgo deriveArgDict ''HashAlgo +instance NFData (HashAlgo a) where + rnf = \case + HashAlgo_MD5 -> () + HashAlgo_SHA1 -> () + HashAlgo_SHA256 -> () + HashAlgo_SHA512 -> () + +instance GNFData HashAlgo where + grnf = rnf + algoToText :: forall t. HashAlgo t -> Text algoToText x = has @NamedAlgo x (algoName @t) diff --git a/hnix-store-core/src/System/Nix/Hash/Truncation.hs b/hnix-store-core/src/System/Nix/Hash/Truncation.hs index 975f65fe..dafaa0b2 100644 --- a/hnix-store-core/src/System/Nix/Hash/Truncation.hs +++ b/hnix-store-core/src/System/Nix/Hash/Truncation.hs @@ -5,10 +5,10 @@ module System.Nix.Hash.Truncation import Data.Word (Word8) import Data.ByteString (ByteString) -import qualified Data.ByteString -import qualified Data.Bits -import qualified Data.Bool -import qualified Data.List +import Data.ByteString qualified +import Data.Bits qualified +import Data.Bool qualified +import Data.List qualified -- | Bytewise truncation of a 'Digest'. -- diff --git a/hnix-store-core/src/System/Nix/OutputName.hs b/hnix-store-core/src/System/Nix/OutputName.hs index 8634d5d2..f25089bf 100644 --- a/hnix-store-core/src/System/Nix/OutputName.hs +++ b/hnix-store-core/src/System/Nix/OutputName.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveAnyClass #-} {-| Description : Derived path output names @@ -6,24 +7,44 @@ Description : Derived path output names module System.Nix.OutputName ( OutputName(..) , mkOutputName + , outputStoreObjectName -- * Re-exports , System.Nix.StorePath.InvalidNameError(..) - , System.Nix.StorePath.parseNameText ) where +import Control.DeepSeq (NFData) import Data.Hashable (Hashable) import Data.Text (Text) import GHC.Generics (Generic) -import System.Nix.StorePath (InvalidNameError) - -import qualified System.Nix.StorePath +import System.Nix.StorePath + ( StorePathName + , InvalidNameError(..) + , mkStorePathName + , unStorePathName + ) -- | Name of the derived path output -- Typically used for "dev", "doc" sub-outputs newtype OutputName = OutputName { -- | Extract the contents of the name. - unOutputName :: Text + unOutputName :: StorePathName } deriving (Eq, Generic, Hashable, Ord, Show) +instance NFData OutputName + mkOutputName :: Text -> Either InvalidNameError OutputName -mkOutputName = fmap OutputName . System.Nix.StorePath.parseNameText +mkOutputName = fmap OutputName . System.Nix.StorePath.mkStorePathName + +-- | Compute the name of an output (store object) from the output name +-- and the derivation name +-- +-- Invalid character errors are not possible, but total length errors are +outputStoreObjectName :: StorePathName -> OutputName -> Either InvalidNameError StorePathName +outputStoreObjectName drvName outputName = case outputNameS of + "out" -> Right drvName + _ -> System.Nix.StorePath.mkStorePathName $ + unStorePathName drvName + <> "-" + <> outputNameS + where + outputNameS = unStorePathName $ unOutputName outputName diff --git a/hnix-store-core/src/System/Nix/Realisation.hs b/hnix-store-core/src/System/Nix/Realisation.hs index 353fe5e5..ccafc40e 100644 --- a/hnix-store-core/src/System/Nix/Realisation.hs +++ b/hnix-store-core/src/System/Nix/Realisation.hs @@ -3,10 +3,10 @@ Description : Derivation realisations -} module System.Nix.Realisation ( - DerivationOutput(..) - , DerivationOutputError(..) - , derivationOutputBuilder - , derivationOutputParser + BuildTraceKey(..) + , BuildTraceKeyError(..) + , buildTraceKeyBuilder + , buildTraceKeyParser , Realisation(..) , RealisationWithId(..) ) where @@ -23,81 +23,81 @@ import System.Nix.OutputName (OutputName, InvalidNameError) import System.Nix.Signature (Signature) import System.Nix.StorePath (StorePath) -import qualified Data.Bifunctor -import qualified Data.Text -import qualified Data.Text.Lazy.Builder -import qualified System.Nix.Hash +import Data.Bifunctor qualified +import Data.Text qualified +import Data.Text.Lazy.Builder qualified +import System.Nix.Hash qualified -- | Output of the derivation -data DerivationOutput a = DerivationOutput - { derivationOutputHash :: DSum HashAlgo Digest +data BuildTraceKey a = BuildTraceKey + { buildTraceKeyHash :: DSum HashAlgo Digest -- ^ Hash modulo of the derivation - , derivationOutputOutput :: a + , buildTraceKeyOutput :: a -- ^ Output (either a OutputName or StorePatH) } deriving (Eq, Generic, Ord, Show) -data DerivationOutputError - = DerivationOutputError_Digest String - | DerivationOutputError_Name InvalidNameError - | DerivationOutputError_NoExclamationMark - | DerivationOutputError_NoColon - | DerivationOutputError_TooManyParts [Text] +data BuildTraceKeyError + = BuildTraceKeyError_Digest String + | BuildTraceKeyError_Name InvalidNameError + | BuildTraceKeyError_NoExclamationMark + | BuildTraceKeyError_NoColon + | BuildTraceKeyError_TooManyParts [Text] deriving (Eq, Ord, Show) -derivationOutputParser +buildTraceKeyParser :: (Text -> Either InvalidNameError outputName) -> Text - -> Either DerivationOutputError (DerivationOutput outputName) -derivationOutputParser outputName dOut = + -> Either BuildTraceKeyError (BuildTraceKey outputName) +buildTraceKeyParser outputName dOut = case Data.Text.splitOn (Data.Text.singleton '!') dOut of - [] -> Left DerivationOutputError_NoColon + [] -> Left BuildTraceKeyError_NoColon [sriHash, oName] -> do hash <- case Data.Text.splitOn (Data.Text.singleton ':') sriHash of - [] -> Left DerivationOutputError_NoColon + [] -> Left BuildTraceKeyError_NoColon [hashName, digest] -> Data.Bifunctor.first - DerivationOutputError_Digest + BuildTraceKeyError_Digest $ System.Nix.Hash.mkNamedDigest hashName digest - x -> Left $ DerivationOutputError_TooManyParts x + x -> Left $ BuildTraceKeyError_TooManyParts x name <- Data.Bifunctor.first - DerivationOutputError_Name + BuildTraceKeyError_Name $ outputName oName - pure $ DerivationOutput hash name - x -> Left $ DerivationOutputError_TooManyParts x + pure $ BuildTraceKey hash name + x -> Left $ BuildTraceKeyError_TooManyParts x -derivationOutputBuilder +buildTraceKeyBuilder :: (outputName -> Text) - -> DerivationOutput outputName + -> BuildTraceKey outputName -> Builder -derivationOutputBuilder outputName DerivationOutput{..} = - System.Nix.Hash.algoDigestBuilder derivationOutputHash +buildTraceKeyBuilder outputName BuildTraceKey{..} = + System.Nix.Hash.algoDigestBuilder buildTraceKeyHash <> Data.Text.Lazy.Builder.singleton '!' - <> Data.Text.Lazy.Builder.fromText (outputName derivationOutputOutput) + <> Data.Text.Lazy.Builder.fromText (outputName buildTraceKeyOutput) -- | Build realisation context -- -- realisationId is ommited since it is a key --- of type @DerivationOutput OutputName@ so +-- of type @BuildTraceKey OutputName@ so -- we will use @RealisationWithId@ newtype data Realisation = Realisation { realisationOutPath :: StorePath -- ^ Output path , realisationSignatures :: Set Signature -- ^ Signatures - , realisationDependencies :: Map (DerivationOutput OutputName) StorePath + , realisationDependencies :: Map (BuildTraceKey OutputName) StorePath -- ^ Dependent realisations required for this one to be valid } deriving (Eq, Generic, Ord, Show) -- | For wire protocol -- -- We store this normalized in @Build.buildResultBuiltOutputs@ --- as @Map (DerivationOutput OutputName) Realisation@ +-- as @Map (BuildTraceKey OutputName) Realisation@ -- but wire protocol needs it de-normalized so we -- need a special (From|To)JSON instances for it newtype RealisationWithId = RealisationWithId - { unRealisationWithId :: (DerivationOutput OutputName, Realisation) + { unRealisationWithId :: (BuildTraceKey OutputName, Realisation) } deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-core/src/System/Nix/Signature.hs b/hnix-store-core/src/System/Nix/Signature.hs index c8e55b73..ac7b7223 100644 --- a/hnix-store-core/src/System/Nix/Signature.hs +++ b/hnix-store-core/src/System/Nix/Signature.hs @@ -22,11 +22,11 @@ import Data.Text (Text) import GHC.Generics (Generic) import System.Nix.Base (decodeWith, encodeWith, BaseEncoding(Base64)) -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import qualified Data.Attoparsec.Text -import qualified Data.ByteArray -import qualified Data.Char -import qualified Data.Text +import Crypto.PubKey.Ed25519 qualified as Ed25519 +import Data.Attoparsec.Text qualified +import Data.ByteArray qualified +import Data.Char qualified +import Data.Text qualified -- | An ed25519 signature. newtype Signature = Signature Ed25519.Signature diff --git a/hnix-store-core/src/System/Nix/StorePath.hs b/hnix-store-core/src/System/Nix/StorePath.hs index 18bcf11d..e13574a8 100644 --- a/hnix-store-core/src/System/Nix/StorePath.hs +++ b/hnix-store-core/src/System/Nix/StorePath.hs @@ -38,6 +38,7 @@ module System.Nix.StorePath , unsafeMakeStorePathHashPart ) where +import Control.DeepSeq (NFData) import Crypto.Hash (HashAlgorithm) import Data.Attoparsec.Text.Lazy (Parser, ()) import Data.ByteString (ByteString) @@ -47,17 +48,17 @@ import Data.Text (Text) import GHC.Generics (Generic) import System.Nix.Base (BaseEncoding(NixBase32)) -import qualified Data.Bifunctor -import qualified Data.ByteString.Char8 -import qualified Data.Char -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified Data.Attoparsec.Text.Lazy -import qualified System.FilePath +import Data.Bifunctor qualified +import Data.ByteString.Char8 qualified +import Data.Char qualified +import Data.Text qualified +import Data.Text.Encoding qualified +import Data.Attoparsec.Text.Lazy qualified +import System.FilePath qualified -import qualified System.Nix.Base -import qualified System.Nix.Hash -import qualified System.Nix.Base32 +import System.Nix.Base qualified +import System.Nix.Hash qualified +import System.Nix.Base32 qualified -- | A path in a Nix store. -- @@ -78,6 +79,8 @@ data StorePath = StorePath } deriving (Eq, Generic, Ord) +instance NFData StorePath + instance Hashable StorePath where hashWithSalt s StorePath{..} = s `hashWithSalt` storePathHash `hashWithSalt` storePathName @@ -98,6 +101,8 @@ newtype StorePathName = StorePathName unStorePathName :: Text } deriving (Eq, Generic, Hashable, Ord, Show) +instance NFData StorePathName + -- | The hash algorithm used for store path hashes. newtype StorePathHashPart = StorePathHashPart { -- | Extract the contents of the hash. @@ -105,6 +110,8 @@ newtype StorePathHashPart = StorePathHashPart } deriving (Eq, Generic, Hashable, Ord, Show) +instance NFData StorePathHashPart + -- | Make @StorePathHashPart@ from @ByteString@ (hash part of the @StorePath@) -- using specific @HashAlgorithm@ mkStorePathHashPart diff --git a/hnix-store-core/src/System/Nix/StorePath/ContentAddressed.hs b/hnix-store-core/src/System/Nix/StorePath/ContentAddressed.hs new file mode 100644 index 00000000..47d2c4c5 --- /dev/null +++ b/hnix-store-core/src/System/Nix/StorePath/ContentAddressed.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.Nix.StorePath.ContentAddressed + ( References(..) + , makeStorePath + , makeFixedOutputPath + ) where + +import Crypto.Hash (Digest, SHA256, HashAlgorithm) +import Data.ByteString (ByteString) +import Data.Constraint.Extras (Has(has)) +import Data.Dependent.Sum (DSum((:=>))) +import Data.HashSet (HashSet) +import Data.Some (Some(Some)) +import System.Nix.ContentAddress (ContentAddressMethod (..)) +import System.Nix.Hash (BaseEncoding(Base16), HashAlgo(..)) +import System.Nix.StorePath (StoreDir, StorePath, StorePathName) + +import Crypto.Hash qualified +import Data.ByteString.Char8 qualified +import Data.ByteString qualified +import Data.HashSet qualified +import Data.List qualified +import Data.Text qualified +import Data.Text.Encoding qualified +import System.Nix.Hash qualified +import System.Nix.StorePath qualified + +data References = References + { references_others :: HashSet StorePath + , references_self :: Bool + } + +instance Semigroup References where + a <> b = References + { references_others = references_others a <> references_others b + , references_self = references_self a || references_self b + } + +instance Monoid References where + mempty = References + { references_others = mempty + , references_self = False + } + +-- | TODO this isn't just for content-addrssed paths, move elsewhere +makeStorePath + :: StoreDir + -> ByteString + -> DSum HashAlgo Digest + -> StorePathName + -> StorePath +makeStorePath storeDir ty (hashAlgo :=> (digest :: Digest a)) nm = + System.Nix.StorePath.unsafeMakeStorePath storeHash nm + where + storeHash = has @HashAlgorithm hashAlgo $ System.Nix.StorePath.mkStorePathHashPart @a s + s = + Data.ByteString.intercalate ":" $ + ty:fmap Data.Text.Encoding.encodeUtf8 + [ System.Nix.Hash.algoToText hashAlgo + , System.Nix.Hash.encodeDigestWith Base16 digest + , Data.Text.pack . Data.ByteString.Char8.unpack $ System.Nix.StorePath.unStoreDir storeDir + , System.Nix.StorePath.unStorePathName nm + ] + +makeType + :: StoreDir + -> ByteString + -> References + -> ByteString +makeType storeDir ty refs = + Data.ByteString.intercalate ":" $ ty : (others ++ self) + where + others = Data.List.sort + $ fmap (System.Nix.StorePath.storePathToRawFilePath storeDir) + $ Data.HashSet.toList + $ references_others refs + self = ["self" | references_self refs] + +makeFixedOutputPath + :: StoreDir + -> ContentAddressMethod + -> DSum HashAlgo Digest + -> References + -> StorePathName + -> StorePath +makeFixedOutputPath storeDir method digest@(hashAlgo :=> h) refs = + makeStorePath storeDir ty digest' + where + (ty, digest') = case method of + ContentAddressMethod_Text -> + case hashAlgo of + HashAlgo_SHA256 + | references_self refs == False -> (makeType storeDir "text" refs, digest) + _ -> error "unsupported" -- TODO do better; maybe we'll just remove this restriction too? + _ -> + if method == ContentAddressMethod_NixArchive + && Some hashAlgo == Some HashAlgo_SHA256 + then (makeType storeDir "source" refs, digest) + else let + h' = + Crypto.Hash.hash @ByteString @SHA256 + $ "fixed:out:" + <> Data.Text.Encoding.encodeUtf8 (System.Nix.Hash.algoToText hashAlgo) + <> (if method == ContentAddressMethod_NixArchive then ":r:" else ":") + <> Data.Text.Encoding.encodeUtf8 (System.Nix.Hash.encodeDigestWith Base16 h) + <> ":" + in ("output:out", HashAlgo_SHA256 :=> h') diff --git a/hnix-store-core/tests/Fingerprint.hs b/hnix-store-core/tests/Fingerprint.hs index 3a53db90..90679bf7 100644 --- a/hnix-store-core/tests/Fingerprint.hs +++ b/hnix-store-core/tests/Fingerprint.hs @@ -16,10 +16,10 @@ import Data.Time.Clock (UTCTime(..)) import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) import Test.Hspec -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import qualified Data.HashSet as HashSet -import qualified Data.Set as Set -import qualified Data.Text.Encoding as Text +import Crypto.PubKey.Ed25519 qualified as Ed25519 +import Data.HashSet qualified as HashSet +import Data.Set qualified as Set +import Data.Text.Encoding qualified as Text spec_fingerprint :: Spec spec_fingerprint = do diff --git a/hnix-store-core/tests/Hash.hs b/hnix-store-core/tests/Hash.hs index 2d735818..0834895b 100644 --- a/hnix-store-core/tests/Hash.hs +++ b/hnix-store-core/tests/Hash.hs @@ -7,10 +7,10 @@ import Data.ByteString (ByteString) import Control.Monad (forM_) import Crypto.Hash (MD5, SHA1, SHA256, hash) -import qualified Data.ByteString.Base16 as B16 -import qualified System.Nix.Base32 as B32 -import qualified Data.ByteString.Base64.Lazy as B64 -import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Base16 qualified as B16 +import System.Nix.Base32 qualified as B32 +import Data.ByteString.Base64.Lazy qualified as B64 +import Data.ByteString.Lazy qualified as BSL import System.Nix.Base diff --git a/hnix-store-core/tests/Signature.hs b/hnix-store-core/tests/Signature.hs index 5841a2be..6102050e 100644 --- a/hnix-store-core/tests/Signature.hs +++ b/hnix-store-core/tests/Signature.hs @@ -5,11 +5,11 @@ module Signature where -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Test.Hspec import Data.Text (Text) -import qualified Crypto.PubKey.Ed25519 -import qualified System.Nix.Base +import Crypto.PubKey.Ed25519 qualified +import System.Nix.Base qualified import System.Nix.Base (BaseEncoding(Base64)) import Crypto.Error (CryptoFailable(..)) diff --git a/hnix-store-core/tests/StorePath.hs b/hnix-store-core/tests/StorePath.hs index 46a28f9f..3c9c742e 100644 --- a/hnix-store-core/tests/StorePath.hs +++ b/hnix-store-core/tests/StorePath.hs @@ -4,7 +4,7 @@ module StorePath where import Test.Hspec (Spec, describe, it, shouldBe) -import qualified Data.Text +import Data.Text qualified import System.Nix.StorePath (parseNameText, InvalidNameError(..)) diff --git a/hnix-store-db/README.md b/hnix-store-db/README.md index e8067540..e93c53c0 100644 --- a/hnix-store-db/README.md +++ b/hnix-store-db/README.md @@ -24,14 +24,14 @@ This example is runnable via `cabal run db-readme`. import Data.Default.Class (Default(def)) -import qualified Control.Monad -import qualified Control.Monad.IO.Class +import Control.Monad qualified +import Control.Monad.IO.Class qualified -import qualified Database.Esqueleto.Experimental +import Database.Esqueleto.Experimental qualified -import qualified System.Nix.StorePath -import qualified System.Nix.Store.DB.Run -import qualified System.Nix.Store.DB.Schema +import System.Nix.StorePath qualified +import System.Nix.Store.DB.Run qualified +import System.Nix.Store.DB.Schema qualified import System.Nix.Store.DB.Query diff --git a/hnix-store-db/apps/Bench.hs b/hnix-store-db/apps/Bench.hs index 9328a485..e0260023 100644 --- a/hnix-store-db/apps/Bench.hs +++ b/hnix-store-db/apps/Bench.hs @@ -1,6 +1,6 @@ module Main where -import qualified System.Nix.Store.DB.Run +import System.Nix.Store.DB.Run qualified main :: IO () main = System.Nix.Store.DB.Run.bench diff --git a/hnix-store-db/hnix-store-db.cabal b/hnix-store-db/hnix-store-db.cabal index 5f14c387..e281009a 100644 --- a/hnix-store-db/hnix-store-db.cabal +++ b/hnix-store-db/hnix-store-db.cabal @@ -32,31 +32,32 @@ flag build-readme common commons ghc-options: -Wall -Wunused-packages default-extensions: - OverloadedStrings + BangPatterns , DataKinds - , DeriveGeneric , DeriveDataTypeable - , DeriveFunctor , DeriveFoldable - , DeriveTraversable + , DeriveFunctor + , DeriveGeneric , DeriveLift + , DeriveTraversable , DerivingStrategies , FlexibleContexts , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , InstanceSigs + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings , RecordWildCards , ScopedTypeVariables , StandaloneDeriving + , TupleSections , TypeApplications , TypeFamilies , TypeOperators , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns , ViewPatterns default-language: Haskell2010 @@ -91,6 +92,7 @@ library , unliftio-core executable db-readme + import: commons if !flag(build-readme) buildable: False build-depends: @@ -101,17 +103,16 @@ executable db-readme , hnix-store-db build-tool-depends: markdown-unlit:markdown-unlit - default-language: Haskell2010 main-is: README.lhs ghc-options: -pgmL markdown-unlit -Wall executable db-bench + import: commons if !flag(build-bench) buildable: False build-depends: base >=4.12 && <5 , hnix-store-db - default-language: Haskell2010 hs-source-dirs: apps main-is: Bench.hs ghc-options: -Wall diff --git a/hnix-store-db/src/System/Nix/Store/DB/Instances.hs b/hnix-store-db/src/System/Nix/Store/DB/Instances.hs index c9301651..fe3425e3 100644 --- a/hnix-store-db/src/System/Nix/Store/DB/Instances.hs +++ b/hnix-store-db/src/System/Nix/Store/DB/Instances.hs @@ -15,13 +15,13 @@ import System.Nix.ContentAddress (ContentAddress) import System.Nix.StorePath (StorePath) import System.Nix.StorePath.Metadata (StorePathTrust(..)) -import qualified Data.Attoparsec.Text -import qualified Data.Bifunctor -import qualified Data.Text -import qualified Data.Time.Clock.POSIX +import Data.Attoparsec.Text qualified +import Data.Bifunctor qualified +import Data.Text qualified +import Data.Time.Clock.POSIX qualified -import qualified System.Nix.ContentAddress -import qualified System.Nix.StorePath +import System.Nix.ContentAddress qualified +import System.Nix.StorePath qualified instance PersistField StorePath where toPersistValue = PersistText . System.Nix.StorePath.storePathToText def diff --git a/hnix-store-db/src/System/Nix/Store/DB/Query.hs b/hnix-store-db/src/System/Nix/Store/DB/Query.hs index d50fac51..acf56092 100644 --- a/hnix-store-db/src/System/Nix/Store/DB/Query.hs +++ b/hnix-store-db/src/System/Nix/Store/DB/Query.hs @@ -29,11 +29,11 @@ import Database.Esqueleto.Experimental import System.Nix.StorePath (StoreDir, StorePath, StorePathHashPart) import System.Nix.Store.DB.Schema -import qualified Data.ByteString.Char8 -import qualified Data.Maybe -import qualified Data.Text -import qualified System.Nix.StorePath -import qualified System.Nix.StorePath.Metadata +import Data.ByteString.Char8 qualified +import Data.Maybe qualified +import Data.Text qualified +import System.Nix.StorePath qualified +import System.Nix.StorePath.Metadata qualified -- * Queries diff --git a/hnix-store-db/src/System/Nix/Store/DB/Run.hs b/hnix-store-db/src/System/Nix/Store/DB/Run.hs index 2811ac2a..2e0161f2 100644 --- a/hnix-store-db/src/System/Nix/Store/DB/Run.hs +++ b/hnix-store-db/src/System/Nix/Store/DB/Run.hs @@ -24,17 +24,17 @@ import Database.Persist.Sqlite (SqliteConnectionInfo) import System.Nix.Store.DB.Query -import qualified Control.Monad -import qualified Control.Monad.IO.Class -import qualified Control.Monad.Logger -import qualified Data.ByteString.Char8 -import qualified Database.Esqueleto.Experimental -import qualified Database.Persist.Sql -import qualified Database.Persist.Sqlite -import qualified System.Log.FastLogger -import qualified System.Nix.StorePath -import qualified System.Nix.Store.DB.Schema -import qualified System.Nix.Store.DB.Util +import Control.Monad qualified +import Control.Monad.IO.Class qualified +import Control.Monad.Logger qualified +import Data.ByteString.Char8 qualified +import Database.Esqueleto.Experimental qualified +import Database.Persist.Sql qualified +import Database.Persist.Sqlite qualified +import System.Log.FastLogger qualified +import System.Nix.StorePath qualified +import System.Nix.Store.DB.Schema qualified +import System.Nix.Store.DB.Util qualified -- | @SqliteConnectionInfo@ for accessing -- systems database in /nix/var/nix/db/db.sqlite diff --git a/hnix-store-db/src/System/Nix/Store/DB/Util.hs b/hnix-store-db/src/System/Nix/Store/DB/Util.hs index a1bac515..a6a1ce95 100644 --- a/hnix-store-db/src/System/Nix/Store/DB/Util.hs +++ b/hnix-store-db/src/System/Nix/Store/DB/Util.hs @@ -14,8 +14,8 @@ import Database.Persist.Quasi import Database.Persist.Sqlite (SqliteConnectionInfo) import Database.Persist.TH (persistWith) -import qualified Database.Persist.Sqlite -import qualified Lens.Micro +import Database.Persist.Sqlite qualified +import Lens.Micro qualified -- | Coerce table names to their plural names -- i.e. ValidPath -> ValidPaths diff --git a/hnix-store-db/tests/Smoke.hs b/hnix-store-db/tests/Smoke.hs index c358110f..055d1f49 100644 --- a/hnix-store-db/tests/Smoke.hs +++ b/hnix-store-db/tests/Smoke.hs @@ -1,6 +1,6 @@ module Main where -import qualified System.Nix.Store.DB.Run +import System.Nix.Store.DB.Run qualified -- This only tests that database can be created -- in-memory using migrateAll and that queryEverything diff --git a/hnix-store-json/hnix-store-json.cabal b/hnix-store-json/hnix-store-json.cabal index 624ceb08..01cd2e28 100644 --- a/hnix-store-json/hnix-store-json.cabal +++ b/hnix-store-json/hnix-store-json.cabal @@ -25,6 +25,7 @@ common commons , DeriveGeneric , DerivingVia , FlexibleInstances + , ImportQualifiedPost , LambdaCase , RecordWildCards , StandaloneDeriving diff --git a/hnix-store-json/src/System/Nix/JSON.hs b/hnix-store-json/src/System/Nix/JSON.hs index b4d037bc..8ad4be88 100644 --- a/hnix-store-json/src/System/Nix/JSON.hs +++ b/hnix-store-json/src/System/Nix/JSON.hs @@ -13,22 +13,22 @@ import Data.Aeson import Deriving.Aeson import System.Nix.Base (BaseEncoding(NixBase32)) import System.Nix.OutputName (OutputName) -import System.Nix.Realisation (DerivationOutput, Realisation, RealisationWithId(..)) +import System.Nix.Realisation (BuildTraceKey, Realisation, RealisationWithId(..)) import System.Nix.Signature (Signature) import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart) -import qualified Data.Aeson.KeyMap -import qualified Data.Aeson.Types -import qualified Data.Attoparsec.Text -import qualified Data.Char -import qualified Data.Text -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder -import qualified System.Nix.Base -import qualified System.Nix.OutputName -import qualified System.Nix.Realisation -import qualified System.Nix.Signature -import qualified System.Nix.StorePath +import Data.Aeson.KeyMap qualified +import Data.Aeson.Types qualified +import Data.Attoparsec.Text qualified +import Data.Char qualified +import Data.Text qualified +import Data.Text.Lazy qualified +import Data.Text.Lazy.Builder qualified +import System.Nix.Base qualified +import System.Nix.OutputName qualified +import System.Nix.Realisation qualified +import System.Nix.Signature qualified +import System.Nix.StorePath qualified instance ToJSON StorePathName where toJSON = toJSON . System.Nix.StorePath.unStorePathName @@ -77,46 +77,46 @@ instance FromJSON StorePath where . Data.Text.cons '/' ) -instance ToJSON (DerivationOutput OutputName) where +instance ToJSON (BuildTraceKey OutputName) where toJSON = toJSON . Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText - . System.Nix.Realisation.derivationOutputBuilder - System.Nix.OutputName.unOutputName + . System.Nix.Realisation.buildTraceKeyBuilder + (System.Nix.StorePath.unStorePathName . System.Nix.OutputName.unOutputName) toEncoding = toEncoding . Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText - . System.Nix.Realisation.derivationOutputBuilder - System.Nix.OutputName.unOutputName + . System.Nix.Realisation.buildTraceKeyBuilder + (System.Nix.StorePath.unStorePathName . System.Nix.OutputName.unOutputName) -instance ToJSONKey (DerivationOutput OutputName) where +instance ToJSONKey (BuildTraceKey OutputName) where toJSONKey = Data.Aeson.Types.toJSONKeyText $ Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText - . System.Nix.Realisation.derivationOutputBuilder - System.Nix.OutputName.unOutputName + . System.Nix.Realisation.buildTraceKeyBuilder + (System.Nix.StorePath.unStorePathName . System.Nix.OutputName.unOutputName) -instance FromJSON (DerivationOutput OutputName) where +instance FromJSON (BuildTraceKey OutputName) where parseJSON = - withText "DerivationOutput OutputName" + withText "BuildTraceKey OutputName" ( either (fail . show) pure - . System.Nix.Realisation.derivationOutputParser + . System.Nix.Realisation.buildTraceKeyParser System.Nix.OutputName.mkOutputName ) -instance FromJSONKey (DerivationOutput OutputName) where +instance FromJSONKey (BuildTraceKey OutputName) where fromJSONKey = FromJSONKeyTextParser ( either (fail . show) pure - . System.Nix.Realisation.derivationOutputParser + . System.Nix.Realisation.buildTraceKeyParser System.Nix.OutputName.mkOutputName ) @@ -159,8 +159,8 @@ deriving instance FromJSON Realisation -- For a keyed version of Realisation --- we use RealisationWithId (DerivationOutput OutputName, Realisation) --- instead of Realisation.id :: (DerivationOutput OutputName) +-- we use RealisationWithId (BuildTraceKey OutputName, Realisation) +-- instead of Realisation.id :: (BuildTraceKey OutputName) -- field. instance ToJSON RealisationWithId where toJSON (RealisationWithId (drvOut, r)) = diff --git a/hnix-store-json/tests/JSONSpec.hs b/hnix-store-json/tests/JSONSpec.hs index 6aad8a84..c9ce9263 100644 --- a/hnix-store-json/tests/JSONSpec.hs +++ b/hnix-store-json/tests/JSONSpec.hs @@ -10,16 +10,16 @@ import Test.Hspec.Nix (forceRight, roundtrips) import System.Nix.Arbitrary () import System.Nix.JSON () import System.Nix.OutputName (OutputName) -import System.Nix.Realisation (DerivationOutput(..), Realisation(..)) +import System.Nix.Realisation (BuildTraceKey(..), Realisation(..)) import System.Nix.Signature (Signature) import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) -import qualified Data.Map -import qualified Data.Set -import qualified System.Nix.Hash -import qualified System.Nix.OutputName -import qualified System.Nix.Signature -import qualified System.Nix.StorePath +import Data.Map qualified +import Data.Set qualified +import System.Nix.Hash qualified +import System.Nix.OutputName qualified +import System.Nix.Signature qualified +import System.Nix.StorePath qualified roundtripsJSON :: ( Eq a @@ -31,14 +31,14 @@ roundtripsJSON -> Expectation roundtripsJSON = roundtrips encode decode -sampleDerivationOutput :: DerivationOutput OutputName -sampleDerivationOutput = DerivationOutput - { derivationOutputHash = +sampleBuildTraceKey :: BuildTraceKey OutputName +sampleBuildTraceKey = BuildTraceKey + { buildTraceKeyHash = forceRight $ System.Nix.Hash.mkNamedDigest "sha256" "1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0" - , derivationOutputOutput = + , buildTraceKeyOutput = forceRight $ System.Nix.OutputName.mkOutputName "foo" } @@ -70,7 +70,7 @@ sampleRealisation1 = Realisation ] , realisationDependencies = Data.Map.fromList - [ ( sampleDerivationOutput + [ ( sampleBuildTraceKey , forceRight $ System.Nix.StorePath.parsePathFromText def @@ -86,13 +86,13 @@ spec = do prop "StorePathName" $ roundtripsJSON @StorePathName prop "StorePathHashPart" $ roundtripsJSON @StorePathHashPart prop "StorePath" $ roundtripsJSON @StorePath - prop "DerivationOutput OutputName" $ roundtripsJSON @(DerivationOutput OutputName) + prop "BuildTraceKey OutputName" $ roundtripsJSON @(BuildTraceKey OutputName) prop "Signature" $ roundtripsJSON @Signature prop "Realisation" $ roundtripsJSON @Realisation describe "ground truth" $ do - it "sampleDerivationOutput matches preimage" $ - encode sampleDerivationOutput `shouldBe` "\"sha256:1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0!foo\"" + it "sampleBuildTraceKey matches preimage" $ + encode sampleBuildTraceKey `shouldBe` "\"sha256:1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0!foo\"" it "sampleRealisation0 matches preimage" $ encode sampleRealisation0 `shouldBe` "{\"outPath\":\"cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.sh\",\"signatures\":[],\"dependentRealisations\":{}}" diff --git a/hnix-store-nar/hnix-store-nar.cabal b/hnix-store-nar/hnix-store-nar.cabal index e8d7c33d..452548bd 100644 --- a/hnix-store-nar/hnix-store-nar.cabal +++ b/hnix-store-nar/hnix-store-nar.cabal @@ -40,6 +40,7 @@ common commons , FlexibleContexts , FlexibleInstances , GADTs + , ImportQualifiedPost , StandaloneDeriving , ScopedTypeVariables , StandaloneDeriving diff --git a/hnix-store-nar/src/System/Nix/Nar.hs b/hnix-store-nar/src/System/Nix/Nar.hs index 05fb9e1b..012a8de3 100644 --- a/hnix-store-nar/src/System/Nix/Nar.hs +++ b/hnix-store-nar/src/System/Nix/Nar.hs @@ -33,14 +33,14 @@ module System.Nix.Nar , Nar.NarSource ) where -import qualified Control.Concurrent as Concurrent -import qualified Data.ByteString as BS -import qualified System.IO as IO +import Control.Concurrent qualified as Concurrent +import Data.ByteString qualified as BS +import System.IO qualified as IO -import qualified System.Nix.Nar.Effects as Nar -import qualified System.Nix.Nar.Options as Nar -import qualified System.Nix.Nar.Parser as Nar -import qualified System.Nix.Nar.Streamer as Nar +import System.Nix.Nar.Effects qualified as Nar +import System.Nix.Nar.Options qualified as Nar +import System.Nix.Nar.Parser qualified as Nar +import System.Nix.Nar.Streamer qualified as Nar -- For a description of the NAR format, see Eelco's thesis -- https://nixos.org/~eelco/pubs/phd-thesis.pdf diff --git a/hnix-store-nar/src/System/Nix/Nar/Effects.hs b/hnix-store-nar/src/System/Nix/Nar/Effects.hs index b2219105..483ef883 100644 --- a/hnix-store-nar/src/System/Nix/Nar/Effects.hs +++ b/hnix-store-nar/src/System/Nix/Nar/Effects.hs @@ -16,10 +16,10 @@ import Data.Int (Int64) import Data.Kind (Type) import System.IO (Handle, IOMode(WriteMode)) -import qualified Control.Monad -import qualified Data.ByteString -import qualified Data.ByteString.Lazy as Bytes.Lazy -import qualified System.Directory as Directory +import Control.Monad qualified +import Data.ByteString qualified +import Data.ByteString.Lazy qualified as Bytes.Lazy +import System.Directory qualified as Directory import System.Posix.Files ( createSymbolicLink , fileMode , fileSize @@ -37,8 +37,8 @@ import System.Posix.Files ( createSymbolicLink , setFileMode , unionFileModes ) -import qualified System.IO as IO -import qualified Control.Exception.Lifted as Exception.Lifted +import System.IO qualified as IO +import Control.Exception.Lifted qualified as Exception.Lifted data IsExecutable = NonExecutable | Executable deriving (Eq, Show) diff --git a/hnix-store-nar/src/System/Nix/Nar/Options.hs b/hnix-store-nar/src/System/Nix/Nar/Options.hs index 867026a1..f16738f4 100644 --- a/hnix-store-nar/src/System/Nix/Nar/Options.hs +++ b/hnix-store-nar/src/System/Nix/Nar/Options.hs @@ -6,7 +6,7 @@ module System.Nix.Nar.Options ) where import Data.Text (Text) -import qualified System.Info +import System.Info qualified -- | Options for configuring how NAR files are encoded and decoded. data NarOptions = NarOptions { diff --git a/hnix-store-nar/src/System/Nix/Nar/Parser.hs b/hnix-store-nar/src/System/Nix/Nar/Parser.hs index 52bc3152..6e64b2e9 100644 --- a/hnix-store-nar/src/System/Nix/Nar/Parser.hs +++ b/hnix-store-nar/src/System/Nix/Nar/Parser.hs @@ -11,42 +11,42 @@ module System.Nix.Nar.Parser ) where -import qualified Algebra.Graph as Graph -import qualified Algebra.Graph.ToGraph as Graph -import qualified Control.Concurrent as Concurrent -import qualified Control.Exception.Lifted as Exception.Lifted +import Algebra.Graph qualified as Graph +import Algebra.Graph.ToGraph qualified as Graph +import Control.Concurrent qualified as Concurrent +import Control.Exception.Lifted qualified as Exception.Lifted import Control.Monad ( forM , when , forM_ ) -import qualified Control.Monad.Except as Except -import qualified Control.Monad.Fail as Fail -import qualified Control.Monad.IO.Class as IO -import qualified Control.Monad.Reader as Reader -import qualified Control.Monad.State as State -import qualified Control.Monad.Trans as Trans -import qualified Control.Monad.Trans.Control as Base +import Control.Monad.Except qualified as Except +import Control.Monad.Fail qualified as Fail +import Control.Monad.IO.Class qualified as IO +import Control.Monad.Reader qualified as Reader +import Control.Monad.State qualified as State +import Control.Monad.Trans qualified as Trans +import Control.Monad.Trans.Control qualified as Base import Data.ByteString (ByteString) -import qualified Data.ByteString as Bytes +import Data.ByteString qualified as Bytes import Data.Bool ( bool ) -import qualified Data.Either as Either +import Data.Either qualified as Either import Data.Int ( Int64 ) -import qualified Data.IORef as IORef -import qualified Data.CaseInsensitive as CI -import qualified Data.HashMap.Strict as HashMap -import qualified Data.List as List -import qualified Data.Map as Map +import Data.IORef qualified as IORef +import Data.CaseInsensitive qualified as CI +import Data.HashMap.Strict qualified as HashMap +import Data.List qualified as List +import Data.Map qualified as Map import Data.Maybe ( catMaybes ) -import qualified Data.Serialize as Serialize +import Data.Serialize qualified as Serialize import Data.Text ( Text ) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified System.Directory as Directory +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import System.Directory qualified as Directory import System.FilePath as FilePath -import qualified System.IO as IO +import System.IO qualified as IO -import qualified System.Nix.Nar.Effects as Nar -import qualified System.Nix.Nar.Options as Nar +import System.Nix.Nar.Effects qualified as Nar +import System.Nix.Nar.Options qualified as Nar -- | NarParser is a monad for parsing a Nar file as a byte stream -- and reconstructing the file system objects inside diff --git a/hnix-store-nar/src/System/Nix/Nar/Streamer.hs b/hnix-store-nar/src/System/Nix/Nar/Streamer.hs index 315e8ba3..19dd43c1 100644 --- a/hnix-store-nar/src/System/Nix/Nar/Streamer.hs +++ b/hnix-store-nar/src/System/Nix/Nar/Streamer.hs @@ -12,23 +12,23 @@ module System.Nix.Nar.Streamer import Data.ByteString (ByteString) import Data.Int (Int64) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Control.Monad ( forM_ , when ) -import qualified Control.Monad.IO.Class as IO -import qualified Data.ByteString as Bytes -import qualified Data.ByteString.Lazy as Bytes.Lazy -import qualified Data.Foldable -import qualified Data.List -import qualified Data.Serialize as Serial -import qualified Data.Text as T (pack, unpack) -import qualified Data.Text.Encoding as TE (encodeUtf8) +import Control.Monad.IO.Class qualified as IO +import Data.ByteString qualified as Bytes +import Data.ByteString.Lazy qualified as Bytes.Lazy +import Data.Foldable qualified +import Data.List qualified +import Data.Serialize qualified as Serial +import Data.Text qualified as T (pack, unpack) +import Data.Text.Encoding qualified as TE (encodeUtf8) import System.FilePath (()) -import qualified System.Nix.Nar.Effects as Nar -import qualified System.Nix.Nar.Options as Nar +import System.Nix.Nar.Effects qualified as Nar +import System.Nix.Nar.Options qualified as Nar -- | NarSource -- The source to provide nar to the handler `(ByteString -> m ())`. diff --git a/hnix-store-nar/tests/NarFormat.hs b/hnix-store-nar/tests/NarFormat.hs index 28d58046..57b3662f 100644 --- a/hnix-store-nar/tests/NarFormat.hs +++ b/hnix-store-nar/tests/NarFormat.hs @@ -4,7 +4,7 @@ module NarFormat where import Control.Applicative (many, optional, (<|>)) -import qualified Control.Concurrent as Concurrent +import Control.Concurrent qualified as Concurrent import Control.Exception (SomeException, try) import Control.Monad (replicateM, void, forM_, when) import Crypto.Hash (hash, Digest, SHA256) @@ -15,35 +15,35 @@ import Data.Serialize (Get, getByteString, import Data.Serialize (Putter, putInt64le, putByteString, runPut) import Data.Bool (bool) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.ByteString qualified as BS +import Data.ByteString.Base64 qualified as B64 +import Data.ByteString.Char8 qualified as BSC +import Data.ByteString.Lazy qualified as BSL +import Data.ByteString.Lazy.Char8 qualified as BSLC import Data.Int ( Int64 ) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E +import Data.Text qualified as T +import Data.Text.Encoding qualified as E import GHC.Generics ( Generic ) import System.Directory ( doesDirectoryExist , doesPathExist , removeDirectoryRecursive , removeFile ) -import qualified System.Directory as Directory +import System.Directory qualified as Directory import System.Environment (getEnv) import System.FilePath ((<.>), ()) -import qualified System.IO as IO -import qualified System.IO.Temp as Temp -import qualified System.Posix.Files as Unix -import qualified System.Posix.Process as Unix -import qualified System.Process as P +import System.IO qualified as IO +import System.IO.Temp qualified as Temp +import System.Posix.Files qualified as Unix +import System.Posix.Process qualified as Unix +import System.Process qualified as P import Test.Tasty as T import Test.Hspec -import qualified Test.Tasty.HUnit as HU +import Test.Tasty.HUnit qualified as HU import Test.Tasty.QuickCheck -import qualified Text.Printf as Printf +import Text.Printf qualified as Printf import Text.Read (readMaybe) import System.Nix.Nar.Streamer (IsExecutable(Executable, NonExecutable)) diff --git a/hnix-store-readonly/hnix-store-readonly.cabal b/hnix-store-readonly/hnix-store-readonly.cabal index ae4c6d3e..ef4628eb 100644 --- a/hnix-store-readonly/hnix-store-readonly.cabal +++ b/hnix-store-readonly/hnix-store-readonly.cabal @@ -22,6 +22,7 @@ common commons default-extensions: Rank2Types , ScopedTypeVariables + , ImportQualifiedPost , TypeApplications default-language: Haskell2010 diff --git a/hnix-store-readonly/src/System/Nix/Store/ReadOnly.hs b/hnix-store-readonly/src/System/Nix/Store/ReadOnly.hs index 2f45efef..f6dfd397 100644 --- a/hnix-store-readonly/src/System/Nix/Store/ReadOnly.hs +++ b/hnix-store-readonly/src/System/Nix/Store/ReadOnly.hs @@ -2,114 +2,21 @@ {-# LANGUAGE OverloadedStrings #-} module System.Nix.Store.ReadOnly - ( References(..) - , makeStorePath - , makeFixedOutputPath - , computeStorePathForPath + ( computeStorePathForPath ) where import Control.Monad.State (StateT, execStateT, modify) -import Crypto.Hash (Context, Digest, SHA256, HashAlgorithm) +import Crypto.Hash (Context, Digest, SHA256) import Data.ByteString (ByteString) -import Data.Constraint.Extras (Has(has)) import Data.Dependent.Sum (DSum((:=>))) -import Data.HashSet (HashSet) -import Data.Some (Some(Some)) +import System.Nix.StorePath.ContentAddressed import System.Nix.ContentAddress (ContentAddressMethod (..)) -import System.Nix.Hash (BaseEncoding(Base16), HashAlgo(..)) +import System.Nix.Hash (HashAlgo(..)) import System.Nix.Store.Types (PathFilter, RepairMode) import System.Nix.StorePath (StoreDir, StorePath, StorePathName) -import qualified Crypto.Hash -import qualified Data.ByteString.Char8 -import qualified Data.ByteString -import qualified Data.HashSet -import qualified Data.List -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified System.Nix.Hash -import qualified System.Nix.Nar -import qualified System.Nix.StorePath - -data References = References - { references_others :: HashSet StorePath - , references_self :: Bool - } - -instance Semigroup References where - a <> b = References - { references_others = references_others a <> references_others b - , references_self = references_self a || references_self b - } - -instance Monoid References where - mempty = References - { references_others = mempty - , references_self = False - } - -makeStorePath - :: StoreDir - -> ByteString - -> DSum HashAlgo Digest - -> StorePathName - -> StorePath -makeStorePath storeDir ty (hashAlgo :=> (digest :: Digest a)) nm = - System.Nix.StorePath.unsafeMakeStorePath storeHash nm - where - storeHash = has @HashAlgorithm hashAlgo $ System.Nix.StorePath.mkStorePathHashPart @a s - s = - Data.ByteString.intercalate ":" $ - ty:fmap Data.Text.Encoding.encodeUtf8 - [ System.Nix.Hash.algoToText hashAlgo - , System.Nix.Hash.encodeDigestWith Base16 digest - , Data.Text.pack . Data.ByteString.Char8.unpack $ System.Nix.StorePath.unStoreDir storeDir - , System.Nix.StorePath.unStorePathName nm - ] - -makeType - :: StoreDir - -> ByteString - -> References - -> ByteString -makeType storeDir ty refs = - Data.ByteString.intercalate ":" $ ty : (others ++ self) - where - others = Data.List.sort - $ fmap (System.Nix.StorePath.storePathToRawFilePath storeDir) - $ Data.HashSet.toList - $ references_others refs - self = ["self" | references_self refs] - -makeFixedOutputPath - :: StoreDir - -> ContentAddressMethod - -> DSum HashAlgo Digest - -> References - -> StorePathName - -> StorePath -makeFixedOutputPath storeDir method digest@(hashAlgo :=> h) refs = - makeStorePath storeDir ty digest' - where - (ty, digest') = case method of - ContentAddressMethod_Text -> - case hashAlgo of - HashAlgo_SHA256 - | references_self refs == False -> (makeType storeDir "text" refs, digest) - _ -> error "unsupported" -- TODO do better; maybe we'll just remove this restriction too? - _ -> - if method == ContentAddressMethod_NixArchive - && Some hashAlgo == Some HashAlgo_SHA256 - then (makeType storeDir "source" refs, digest) - else let - h' = - Crypto.Hash.hash @ByteString @SHA256 - $ "fixed:out:" - <> Data.Text.Encoding.encodeUtf8 (System.Nix.Hash.algoToText hashAlgo) - <> (if method == ContentAddressMethod_NixArchive then ":r:" else ":") - <> Data.Text.Encoding.encodeUtf8 (System.Nix.Hash.encodeDigestWith Base16 h) - <> ":" - in ("output:out", HashAlgo_SHA256 :=> h') +import Crypto.Hash qualified +import System.Nix.Nar qualified digestPath :: FilePath -- ^ Local `FilePath` to add diff --git a/hnix-store-readonly/tests/ReadOnlySpec.hs b/hnix-store-readonly/tests/ReadOnlySpec.hs index ff5c9166..889de623 100644 --- a/hnix-store-readonly/tests/ReadOnlySpec.hs +++ b/hnix-store-readonly/tests/ReadOnlySpec.hs @@ -10,10 +10,11 @@ import Data.ByteString (ByteString) import Data.Dependent.Sum (DSum(..)) import System.Nix.Hash (HashAlgo(..)) import System.Nix.StorePath (StorePath, StorePathName) +import System.Nix.StorePath.ContentAddressed import System.Nix.ContentAddress (ContentAddressMethod(..)) -import qualified Data.HashSet -import qualified System.Nix.StorePath +import Data.HashSet qualified +import System.Nix.StorePath qualified import System.Nix.Store.ReadOnly diff --git a/hnix-store-remote/app/BuildDerivation.hs b/hnix-store-remote/app/BuildDerivation.hs index 1d321c79..416d824c 100644 --- a/hnix-store-remote/app/BuildDerivation.hs +++ b/hnix-store-remote/app/BuildDerivation.hs @@ -3,11 +3,11 @@ module Main where import Data.Default.Class (Default(def)) -import qualified Data.Text -import qualified System.Environment -import qualified System.Nix.Build -import qualified System.Nix.StorePath -import qualified System.Nix.Store.Remote +import Data.Text qualified +import System.Environment qualified +import System.Nix.Build qualified +import System.Nix.StorePath qualified +import System.Nix.Store.Remote qualified main :: IO () main = System.Environment.getArgs >>= \case diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index bfc45b18..c324d156 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -31,6 +31,7 @@ common commons , DerivingVia , FlexibleContexts , FlexibleInstances + , ImportQualifiedPost , GADTs , RecordWildCards , ScopedTypeVariables @@ -92,7 +93,6 @@ library , System.Nix.Store.Remote.Types.Query.Missing , System.Nix.Store.Remote.Types.StoreConfig , System.Nix.Store.Remote.Types.StoreRequest - , System.Nix.Store.Remote.Types.StoreReply , System.Nix.Store.Remote.Types.StoreText , System.Nix.Store.Remote.Types.SubstituteMode , System.Nix.Store.Remote.Types.SuccessCodeReply @@ -107,6 +107,7 @@ library , hnix-store-json >= 0.1 , hnix-store-nar >= 0.1 , hnix-store-tests >= 0.1 + , hnix-store-aterm , aeson , attoparsec , bytestring @@ -122,6 +123,7 @@ library , exceptions , generic-arbitrary < 1.1 , hashable + , mmorph , text , time , transformers @@ -135,6 +137,7 @@ library ghc-options: -Wall executable build-derivation + import: commons if !flag(build-derivation) buildable: False build-depends: @@ -143,12 +146,12 @@ executable build-derivation , hnix-store-remote , data-default-class , text - default-language: Haskell2010 main-is: BuildDerivation.hs hs-source-dirs: app ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N" executable remote-readme + import: commons if !flag(build-readme) buildable: False build-depends: @@ -157,7 +160,6 @@ executable remote-readme , hnix-store-remote build-tool-depends: markdown-unlit:markdown-unlit - default-language: Haskell2010 main-is: README.lhs ghc-options: -pgmL markdown-unlit -Wall @@ -178,12 +180,14 @@ test-suite remote , hnix-store-core , hnix-store-remote , hnix-store-tests + , hnix-store-aterm , bytestring , crypton , some > 1.0.5 && < 2 , time , hspec , QuickCheck + , transformers test-suite remote-io import: commons diff --git a/hnix-store-remote/src/Data/Serializer.hs b/hnix-store-remote/src/Data/Serializer.hs index d1e525dd..b5630a5b 100644 --- a/hnix-store-remote/src/Data/Serializer.hs +++ b/hnix-store-remote/src/Data/Serializer.hs @@ -29,18 +29,19 @@ module Data.Serializer , SimpleSerializer -- ** Simple runners , runGetSimple - , runPutSimple -- * From Get/Put, Serialize , lift2 , liftSerialize -- * Combinators + , AlmostPrism(..) + , maybeAlmostPrism , mapIsoSerializer , mapPrismSerializer , tup + , depTup -- * Utility , GetSerializerError(..) , transformGetError - , transformPutError -- * Re-exports , Get , PutM @@ -49,16 +50,15 @@ module Data.Serializer #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) #endif -import Control.Monad.Except (MonadError, throwError) -import Control.Monad.Trans (lift) -import Control.Monad.Trans (MonadTrans) +import Control.Monad.Morph import Control.Monad.Trans.Identity (IdentityT, runIdentityT) import Data.ByteString (ByteString) +import Data.Functor.Identity import Data.Serialize (Serialize) +import Data.Serialize qualified import Data.Serialize.Get (Get, runGet) import Data.Serialize.Put (Putter, PutM, runPutM) -import qualified Data.Serialize -- * Serializer @@ -68,21 +68,17 @@ import qualified Data.Serialize -- for e.g. adding @ExceptT@ or @ReaderT@ layers. data Serializer t a = Serializer { getS :: t Get a - , putS :: a -> t PutM () + , putS :: a -> PutM () } -- ** Runners -- | Runner for putS of @Serializer@ runPutS - :: ( Monad (t PutM) - , MonadTrans t - ) - => Serializer t a -- ^ Serializer - -> (t PutM () -> PutM b) -- ^ Tranformer runner + :: Serializer t a -- ^ Serializer -> a -- ^ Value to (out)put - -> (b, ByteString) -runPutS s run a = runPutM $ run $ (putS s) a + -> ByteString +runPutS s = snd . runPutM . putS s -- | Runner for getS of @Serializer@ runGetS @@ -110,15 +106,6 @@ runGetSimple runGetSimple s b = runGetS s (runIdentityT) b --- | Runner for putS of @SimpleSerializer@ -runPutSimple - :: SimpleSerializer a - -> a - -> ByteString -runPutSimple s = - snd - . runPutS s runIdentityT - -- * From Get/Put, Serialize -- | Lift @Get a@ and @Putter a@ into @Serializer@ @@ -130,7 +117,7 @@ lift2 -> Serializer t a lift2 f g = Serializer { getS = lift f - , putS = lift . g + , putS = g } -- | Lift @Serialize a@ instance into @Serializer@ @@ -158,17 +145,34 @@ mapIsoSerializer f g s = Serializer , putS = putS s . g } +data AlmostPrism t a b = AlmostPrism + { _almostPrism_get :: a -> t Identity b + -- ^ Map over @getS@ + , _almostPrism_put :: b -> a + -- ^ Map over @putS@ + } + +maybeAlmostPrism + :: Applicative (t Identity) + => AlmostPrism t a b + -> AlmostPrism t (Maybe a) (Maybe b) +maybeAlmostPrism ap = AlmostPrism + { _almostPrism_get = traverse $ _almostPrism_get ap + , _almostPrism_put = fmap $ _almostPrism_put ap + } + -- | Map over @Serializer@ where @getS@ -- can return @Either@ mapPrismSerializer - :: MonadError eGet (t Get) - => (a -> Either eGet b) -- ^ Map over @getS@ - -> (b -> a) -- ^ Map over @putS@ + :: ( Monad (t Get) + , MFunctor t + ) + => AlmostPrism t a b -> Serializer t a -> Serializer t b -mapPrismSerializer f g s = Serializer - { getS = either throwError pure . f =<< getS s - , putS = putS s . g +mapPrismSerializer p s = Serializer + { getS = hoist generalize . _almostPrism_get p =<< getS s + , putS = putS s . _almostPrism_put p } -- | Tuple combinator @@ -186,6 +190,24 @@ tup a b = Serializer putS b y } +-- | Dependent tuple combinator +depTup + :: ( Monad (t Get) + , Monad (t PutM) + ) + => Serializer t a + -> (a -> Serializer t b) + -> Serializer t (a, b) +depTup sa sb = Serializer + { getS = do + a <- getS sa + b <- getS $ sb a + pure (a, b) + , putS = \(x, y) -> do + putS sa x + putS (sb x) y + } + -- * Utilities -- | Wrapper for both GetS errors @@ -206,9 +228,3 @@ transformGetError = \case Left stringyRunGetError -> Left (SerializerError_GetFail stringyRunGetError) Right (Left myGetError) -> Left (SerializerError_Get myGetError) Right (Right res) -> Right res - --- | Helper for transforming @runPutM@ result -transformPutError - :: (Either customPutError (), ByteString) - -> Either customPutError ByteString -transformPutError (e, r) = either Left (pure $ Right r) e diff --git a/hnix-store-remote/src/Data/Serializer/Example.hs b/hnix-store-remote/src/Data/Serializer/Example.hs index a53d6dc9..ea37070e 100644 --- a/hnix-store-remote/src/Data/Serializer/Example.hs +++ b/hnix-store-remote/src/Data/Serializer/Example.hs @@ -11,16 +11,11 @@ module Data.Serializer.Example , runP -- * Custom errors , MyGetError(..) - , MyPutError(..) -- ** Erroring variants of cmdS - -- *** putS with throwError and MyPutError - , cmdSPutError -- *** getS with throwError and MyGetError , cmdSGetError -- *** getS with fail , cmdSGetFail - -- *** putS with fail - , cmdSPutFail -- * Elaborate , cmdSRest , runGRest @@ -28,13 +23,13 @@ module Data.Serializer.Example ) where import Control.Monad.Except (MonadError, throwError) -import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Reader (MonadReader) import Control.Monad.State (MonadState) import Control.Monad.Trans (MonadTrans, lift) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.State (StateT, runStateT) -import Data.Bifunctor (first, second) +import Data.Bifunctor (second) import Data.ByteString (ByteString) import Data.Int (Int8) import Data.GADT.Show (GShow(..), defaultGshowsPrec) @@ -48,7 +43,6 @@ import Data.Serializer , runGetS , runPutS , transformGetError - , transformPutError ) import Data.Some (Some(..)) import GHC.Generics (Generic) @@ -97,25 +91,25 @@ instance Arbitrary (Some Cmd) where opcode :: MonadTrans t => Serializer t OpCode opcode = Serializer { getS = lift getEnum - , putS = lift . putEnum + , putS = putEnum } -- * Cmd Serializer -- | @Cmd@ @Serializer@ cmdS - :: forall t . ( MonadTrans t - , Monad (t Get) - , Monad (t PutM) - ) + :: forall t + . ( MonadTrans t + , Monad (t Get) + ) => Serializer t (Some Cmd) cmdS = Serializer { getS = getS opcode >>= \case OpCode_Int -> Some . Cmd_Int <$> lift getInt8 OpCode_Bool -> Some . Cmd_Bool <$> lift getBool , putS = \case - Some (Cmd_Int i) -> putS opcode OpCode_Int >> lift (putInt8 i) - Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b) + Some (Cmd_Int i) -> putS (opcode @t) OpCode_Int >> putInt8 i + Some (Cmd_Bool b) -> putS (opcode @t) OpCode_Bool >> putBool b } -- * Runners @@ -133,10 +127,8 @@ runG s = runP :: Serializer (ExceptT e) a -> a - -> Either e ByteString -runP s = - (\(e, r) -> either Left (pure $ Right r) e) - . runPutS s runExceptT + -> ByteString +runP = runPutS -- * Custom errors @@ -144,22 +136,8 @@ data MyGetError = MyGetError_Example deriving (Eq, Show) -data MyPutError - = MyPutError_NoLongerSupported -- no longer supported protocol version - deriving (Eq, Show) - -- ** Erroring variants of cmdS --- *** putS with throwError and MyPutError - -cmdSPutError :: Serializer (ExceptT MyPutError) (Some Cmd) -cmdSPutError = Serializer - { getS = getS cmdS - , putS = \case - Some (Cmd_Int i) -> putS opcode OpCode_Int >> lift (putInt8 i) - Some (Cmd_Bool _b) -> throwError MyPutError_NoLongerSupported - } - -- *** getS with throwError and MyGetError cmdSGetError :: Serializer (ExceptT MyGetError) (Some Cmd) @@ -167,13 +145,14 @@ cmdSGetError = Serializer { getS = getS opcode >>= \case OpCode_Int -> Some . Cmd_Int <$> lift getInt8 OpCode_Bool -> throwError MyGetError_Example - , putS = putS cmdS + , putS = putS $ cmdS @(ExceptT MyGetError) } -- *** getS with fail cmdSGetFail - :: ( MonadTrans t + :: forall t + . ( MonadTrans t , MonadFail (t Get) , Monad (t PutM) ) @@ -182,26 +161,7 @@ cmdSGetFail = Serializer { getS = getS opcode >>= \case OpCode_Int -> Some . Cmd_Int <$> lift getInt8 OpCode_Bool -> fail "no parse" - , putS = putS cmdS - } - --- *** putS with fail - --- | Unused as PutM doesn't have @MonadFail@ --- >>> serializerPutFail = cmdPutFail @(ExceptT MyGetError) --- No instance for (MonadFail PutM) --- as expected -cmdSPutFail - :: ( MonadTrans t - , MonadFail (t PutM) - , Monad (t Get) - ) - => Serializer t (Some Cmd) -cmdSPutFail = Serializer - { getS = getS cmdS - , putS = \case - Some (Cmd_Int i) -> putS opcode OpCode_Int >> lift (putInt8 i) - Some (Cmd_Bool _b) -> fail "can't" + , putS = putS $ cmdS @t } -- * Elaborate @@ -250,35 +210,29 @@ runGRest serializer r s = runPRest :: Serializer (REST r e s) a - -> r - -> s -> a - -> Either e ByteString -runPRest serializer r s = - transformPutError - . first fst - . runPutS - serializer - (restRunner r s) + -> ByteString +runPRest = runPutS cmdSRest - :: Serializer (REST Bool e Int) (Some Cmd) -cmdSRest = Serializer + :: forall t e + . t ~ REST Bool e Int + => Bool + -> Serializer t (Some Cmd) +cmdSRest isTrue = Serializer { getS = getS opcode >>= \case OpCode_Int -> do - isTrue <- ask if isTrue then Some . Cmd_Int . (+1) <$> lift getInt8 else Some . Cmd_Int <$> lift getInt8 OpCode_Bool -> Some . Cmd_Bool <$> lift getBool , putS = \case Some (Cmd_Int i) -> do - putS opcode OpCode_Int - isTrue <- ask + putS (opcode @t) OpCode_Int if isTrue - then lift (putInt8 (i - 1)) - else lift (putInt8 i) - Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b) + then putInt8 (i - 1) + else putInt8 i + Some (Cmd_Bool b) -> putS (opcode @t) OpCode_Bool >> putBool b } -- Primitives helpers diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 2128ca94..61b05858 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -33,14 +33,14 @@ import System.Nix.Store.Remote.Client import System.Nix.Store.Remote.Server (WorkerHelper, runProxyDaemon) import System.Nix.Store.Remote.Types -import qualified Control.Monad.Catch -import qualified Network.Socket +import Control.Monad.Catch qualified +import Network.Socket qualified -- see TODO bellow ---import qualified System.Directory +--import System.Directory qualified -- wip justdoit import System.Nix.StorePath (StorePath) -import qualified System.Nix.StorePath +import System.Nix.StorePath qualified -- * Compat diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 55933e65..3f592af3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -38,6 +38,8 @@ import Data.Some (Some) import Data.Word (Word64) import System.Nix.Build (BuildMode, BuildResult) +import System.Nix.Derivation.Traditional qualified +import System.Nix.Derivation.ATerm qualified import System.Nix.DerivedPath (DerivedPath) import System.Nix.Hash (HashAlgo(..)) import System.Nix.Nar (NarSource) @@ -55,11 +57,11 @@ import System.Nix.Store.Remote.Client.Core import System.Nix.FileContentAddress (FileIngestionMethod(..)) import System.Nix.Store.Types (RepairMode(..)) -import qualified Control.Monad.IO.Class -import qualified Data.Attoparsec.Text -import qualified Data.Text.IO -import qualified System.Nix.Derivation -import qualified System.Nix.StorePath +import Control.Monad.IO.Class qualified +import Data.Attoparsec.Text qualified +import Data.Text.IO qualified +import System.Nix.Derivation qualified +import System.Nix.StorePath qualified -- | Add `NarSource` to the store addToStore @@ -145,9 +147,24 @@ buildDerivation sp mode = do $ Data.Text.IO.readFile $ System.Nix.StorePath.storePathToFilePath sd sp case Data.Attoparsec.Text.parseOnly - (System.Nix.Derivation.parseDerivation sd) drvContents of + (System.Nix.Derivation.ATerm.parseTraditionalDerivation sd) drvContents of Left e -> throwError $ RemoteStoreError_DerivationParse e - Right drv -> doReq (BuildDerivation sp drv mode) + Right drv -> do + let name = System.Nix.StorePath.storePathName sp + outputs <- case + System.Nix.Derivation.toSpecificOutputs sd name $ + System.Nix.Derivation.Traditional.anonOutputs drv + of + Nothing -> throwError $ RemoteStoreError_DerivationParse "TODO get error" + Just os -> pure os + let drv' = System.Nix.Derivation.Traditional.withName name $ + drv + { System.Nix.Derivation.Traditional.anonOutputs = outputs + , System.Nix.Derivation.Traditional.anonInputs = + System.Nix.Derivation.Traditional.traditionalSrcs + (System.Nix.Derivation.Traditional.anonInputs drv) + } + doReq (BuildDerivation sp drv' mode) -- | Build paths if they are an actual derivations. -- diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs index 5373dd19..422aade0 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs @@ -21,25 +21,27 @@ import System.Nix.Store.Remote.MonadStore ) import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) import System.Nix.Store.Remote.Serializer - ( bool + ( ReplySError(ReplySError_PrimGet) + , bool , int , mapErrorS , protoVersion + , storePath , storeRequest , text , trustedFlag , workerMagic ) + import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeOutput(..)) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.NoReply (NoReply(..)) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..)) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) -import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..)) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) -import qualified Data.ByteString -import qualified Network.Socket.ByteString +import Data.ByteString qualified +import Network.Socket.ByteString qualified type Run m a = m (Either RemoteStoreError a, DList Logger) @@ -48,17 +50,19 @@ doReq :: forall m a . ( MonadIO m , MonadRemoteStore m - , StoreReply a , Show a ) => StoreRequest a -> m a doReq = \case x -> do + storeDir <- getStoreDir + pv <- getProtoVersion + sockPutS (mapErrorS RemoteStoreError_SerializerRequest - storeRequest + $ storeRequest storeDir pv ) (Some x) @@ -76,7 +80,7 @@ doReq = \case throwError RemoteStoreError_NoNarSourceProvided processOutput - processReply + sockGetS $ mapErrorS (RemoteStoreError_SerializerReply . ReplySError_PrimGet) $ storePath storeDir AddToStoreNar _ meta _ _ -> do let narBytes = maybe 0 id $ metadataNarBytes meta @@ -109,13 +113,8 @@ doReq = \case _ -> do processOutput - processReply - - where - processReply = sockGetS - (mapErrorS RemoteStoreError_SerializerReply - $ getReplyS @a - ) + error "need to keep casing on arguments" + --sockGetS $ mapErrorS (RemoteStoreError_SerializerReply . ReplySError_PrimGet) copyToSink :: forall m diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs index 4e9afa3d..ba7e0415 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -2,20 +2,20 @@ module System.Nix.Store.Remote.Logger ( processOutput ) where -import Control.Monad.Except (throwError) +import Control.Monad.Except (runExceptT, throwError) import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import Data.Serialize (Result(..)) -import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT) +import System.Nix.Store.Remote.Serializer (LoggerSError, logger) import System.Nix.Store.Remote.Socket (sockGet8) import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, RemoteStoreError(..), appendLog, getDataSource, getDataSink, getStoreSocket, getProtoVersion) import System.Nix.Store.Remote.Types.Logger (Logger(..)) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) -import qualified Control.Monad -import qualified Data.Serialize.Get -import qualified Data.Serializer -import qualified Network.Socket.ByteString +import Control.Monad qualified +import Data.Serialize.Get qualified +import Data.Serializer qualified +import Network.Socket.ByteString qualified processOutput :: MonadRemoteStore m @@ -30,7 +30,7 @@ processOutput = do -> Result (Either LoggerSError Logger) decoder protoVersion = Data.Serialize.Get.runGetPartial - (runSerialT protoVersion $ Data.Serializer.getS logger) + (runExceptT $ Data.Serializer.getS $ logger protoVersion) go :: MonadRemoteStore m diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs index ab147b04..0b32f588 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -33,7 +33,7 @@ import System.Nix.Store.Remote.Types.Logger (Logger, BasicError, ErrorInfo) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..)) -import qualified Data.DList +import Data.DList qualified data RemoteStoreState = RemoteStoreState { remoteStoreStateConfig :: ProtoStoreConfig diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 37e7253b..16a77d31 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -9,12 +9,11 @@ module System.Nix.Store.Remote.Serializer ( -- * NixSerializer NixSerializer - , mapReaderS , mapErrorS -- * Errors , SError(..) -- ** Runners - , runSerialT + , runExceptT , runG , runP -- * Primitives @@ -54,7 +53,7 @@ module System.Nix.Store.Remote.Serializer -- * DSum HashAlgo Digest , namedDigest -- * Derivation - , derivation + , basicDerivation -- * Derivation , derivedPath -- * Build @@ -87,7 +86,7 @@ module System.Nix.Store.Remote.Serializer , opSuccess , noop -- *** Realisation - , derivationOutputTyped + , buildTraceKeyTyped , realisation , realisationWithId -- *** BuildResult @@ -102,143 +101,86 @@ module System.Nix.Store.Remote.Serializer , maybePathMetadata ) where + +import Control.Monad qualified import Control.Monad.Except (MonadError, throwError, ) -import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans (MonadTrans, lift) -import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT) -import Control.Monad.Trans.Except (ExceptT, mapExceptT, runExceptT, withExceptT) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT, withExceptT) import Crypto.Hash (Digest, HashAlgorithm, SHA256) import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified +import Data.Attoparsec.Text qualified +import Data.Bifunctor qualified +import Data.Bits qualified import Data.ByteString (ByteString) +import Data.ByteString qualified +import Data.ByteString.Char8 qualified +import Data.ByteString.Lazy qualified import Data.Dependent.Sum (DSum((:=>))) import Data.Fixed (Uni) -import Data.Hashable (Hashable) +import Data.Functor.Identity import Data.HashSet (HashSet) +import Data.HashSet qualified +import Data.Hashable (Hashable) import Data.Map (Map) +import Data.Map.Strict qualified +import Data.Maybe qualified +import Data.Serialize.Get qualified +import Data.Serialize.Put qualified import Data.Serializer import Data.Set (Set) +import Data.Set qualified import Data.Some (Some(Some)) +import Data.Some qualified import Data.Text (Text) +import Data.Text qualified +import Data.Text.Encoding qualified +import Data.Text.Lazy qualified import Data.Text.Lazy.Builder (Builder) +import Data.Text.Lazy.Builder qualified import Data.Time (NominalDiffTime, UTCTime) +import Data.Time.Clock.POSIX qualified import Data.Vector (Vector) +import Data.Vector qualified import Data.Word (Word8, Word32, Word64) import GHC.Generics (Generic) import System.Nix.Base (BaseEncoding(Base16, NixBase32)) +import System.Nix.Base qualified import System.Nix.Build (BuildMode, BuildResult(..)) import System.Nix.ContentAddress (ContentAddress) -import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) +import System.Nix.ContentAddress qualified +import System.Nix.Derivation.Traditional +import System.Nix.Derivation import System.Nix.DerivedPath (DerivedPath(..), ParseOutputsError) +import System.Nix.DerivedPath qualified +import System.Nix.FileContentAddress (FileIngestionMethod(..)) import System.Nix.Hash (HashAlgo(..)) +import System.Nix.Hash qualified import System.Nix.JSON () import System.Nix.OutputName (OutputName) -import System.Nix.Realisation (DerivationOutputError, Realisation(..), RealisationWithId(..)) +import System.Nix.OutputName qualified +import System.Nix.Realisation (BuildTraceKeyError, Realisation(..), RealisationWithId(..)) +import System.Nix.Realisation qualified import System.Nix.Signature (Signature, NarSignature) -import System.Nix.FileContentAddress (FileIngestionMethod(..)) +import System.Nix.Signature qualified +import System.Nix.Store.Remote.Types import System.Nix.Store.Types (RepairMode(..)) -import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) +import System.Nix.StorePath (StoreDir, InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) +import System.Nix.StorePath qualified import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) -import System.Nix.Store.Remote.Types - -import qualified Control.Monad -import qualified Control.Monad.Reader -import qualified Data.Aeson -import qualified Data.Attoparsec.Text -import qualified Data.Bifunctor -import qualified Data.Bits -import qualified Data.ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy -import qualified Data.Coerce -import qualified Data.HashSet -import qualified Data.Map.Strict -import qualified Data.Maybe -import qualified Data.Serialize.Get -import qualified Data.Serialize.Put -import qualified Data.Set -import qualified Data.Some -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder -import qualified Data.Time.Clock.POSIX -import qualified Data.Vector -import qualified System.Nix.Base -import qualified System.Nix.ContentAddress -import qualified System.Nix.DerivedPath -import qualified System.Nix.Hash -import qualified System.Nix.OutputName -import qualified System.Nix.Realisation -import qualified System.Nix.Signature -import qualified System.Nix.StorePath - --- | Transformer for @Serializer@ -newtype SerialT r e m a = SerialT - { _unSerialT :: ExceptT e (ReaderT r m) a } - deriving - ( Applicative - , Functor - , Monad - , MonadError e - , MonadReader r - , MonadFail - ) - -instance MonadTrans (SerialT r e) where - lift = SerialT . lift . lift - --- | Runner for @SerialT@ -runSerialT - :: Monad m - => r - -> SerialT r e m a - -> m (Either e a) -runSerialT r = - (`runReaderT` r) - . runExceptT - . _unSerialT - -mapErrorST - :: Functor m - => (e -> e') - -> SerialT r e m a - -> SerialT r e' m a -mapErrorST f = - SerialT - . withExceptT f - . _unSerialT mapErrorS :: (e -> e') - -> NixSerializer r e a - -> NixSerializer r e' a + -> NixSerializer e a + -> NixSerializer e' a mapErrorS f s = Serializer - { getS = mapErrorST f $ getS s - , putS = mapErrorST f . putS s - } - -mapReaderST - :: Functor m - => (r' -> r) - -> SerialT r e m a - -> SerialT r' e m a -mapReaderST f = - SerialT - . (mapExceptT . withReaderT) f - . _unSerialT - -mapReaderS - :: (r' -> r) - -> NixSerializer r e a - -> NixSerializer r' e a -mapReaderS f s = Serializer - { getS = mapReaderST f $ getS s - , putS = mapReaderST f . putS s + { getS = withExceptT f $ getS s + , putS = putS s } -- * NixSerializer -type NixSerializer r e = Serializer (SerialT r e) +type NixSerializer e = Serializer (ExceptT e) -- * Errors @@ -250,8 +192,9 @@ data SError , badPaddingPads :: [Word8] } | SError_ContentAddress String + | SError_DerivingPath | SError_DerivedPath ParseOutputsError - | SError_DerivationOutput DerivationOutputError + | SError_BuildTraceKey BuildTraceKeyError | SError_Digest String | SError_EnumOutOfMinBound Int | SError_EnumOutOfMaxBound Int @@ -259,11 +202,12 @@ data SError | SError_IllegalBool Word64 | SError_InvalidNixBase32 | SError_JSONDecoding String - | SError_NarHashMustBeSHA256 + -- | SError_NarHashMustBeSHA256 | SError_NotYetImplemented String (ForPV ProtoVersion) | SError_Name InvalidNameError | SError_Path InvalidPathError | SError_Signature String + | SError_DerivationOutputInvalidCombo Bool Bool Bool deriving (Eq, Ord, Generic, Show) data ForPV a @@ -274,36 +218,30 @@ data ForPV a -- ** Runners runG - :: NixSerializer r e a - -> r + :: NixSerializer e a -> ByteString -> Either (GetSerializerError e) a -runG serializer r = +runG serializer = transformGetError . runGetS serializer - (runSerialT r) + (runExceptT) runP - :: NixSerializer r e a - -> r + :: NixSerializer e a -> a - -> Either e ByteString -runP serializer r = - transformPutError - . runPutS - serializer - (runSerialT r) + -> ByteString +runP = runPutS -- * Primitives -int :: Integral a => NixSerializer r e a +int :: Integral a => NixSerializer e a int = Serializer { getS = fromIntegral <$> lift Data.Serialize.Get.getWord64le - , putS = lift . Data.Serialize.Put.putWord64le . fromIntegral + , putS = Data.Serialize.Put.putWord64le . fromIntegral } -bool :: NixSerializer r SError Bool +bool :: NixSerializer SError Bool bool = Serializer { getS = getS (int @Word64) >>= \case 0 -> pure False @@ -314,7 +252,7 @@ bool = Serializer True -> putS (int @Word8) 1 } -byteString :: NixSerializer r SError ByteString +byteString :: NixSerializer SError ByteString byteString = Serializer { getS = do len <- getS int @@ -329,7 +267,7 @@ byteString = Serializer , putS = \x -> do let len = Data.ByteString.length x putS int len - lift $ Data.Serialize.Put.putByteString x + Data.Serialize.Put.putByteString x Control.Monad.when (len `mod` 8 /= 0) $ pad $ 8 - (len `mod` 8) @@ -342,7 +280,16 @@ byteString = Serializer pad count = Control.Monad.replicateM_ count - (lift $ Data.Serialize.Put.putWord8 0) + (Data.Serialize.Put.putWord8 0) + +maybeByteString :: NixSerializer SError (Maybe ByteString) +maybeByteString = mapIsoSerializer + (\case + t | Data.ByteString.null t -> Nothing + t | otherwise -> Just t + ) + (Data.Maybe.fromMaybe mempty) + byteString -- | Utility toEnum version checking bounds using Bounded class toEnumCheckBoundsM @@ -362,26 +309,26 @@ enum :: ( Bounded a , Enum a ) - => NixSerializer r SError a + => NixSerializer SError a enum = Serializer { getS = getS int >>= toEnumCheckBoundsM , putS = putS int . fromEnum } -text :: NixSerializer r SError Text +text :: NixSerializer SError Text text = mapIsoSerializer Data.Text.Encoding.decodeUtf8 Data.Text.Encoding.encodeUtf8 byteString -- TODO Parser Builder -_textBuilder :: NixSerializer r SError Builder +_textBuilder :: NixSerializer SError Builder _textBuilder = Serializer { getS = Data.Text.Lazy.Builder.fromText <$> getS text , putS = putS text . Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText } -maybeText :: NixSerializer r SError (Maybe Text) +maybeText :: NixSerializer SError (Maybe Text) maybeText = mapIsoSerializer (\case t | Data.Text.null t -> Nothing @@ -392,7 +339,7 @@ maybeText = mapIsoSerializer -- * UTCTime -time :: NixSerializer r e UTCTime +time :: NixSerializer e UTCTime time = Serializer { getS = Data.Time.Clock.POSIX.posixSecondsToUTCTime @@ -415,8 +362,8 @@ time = Serializer -- * Combinators list - :: NixSerializer r e a - -> NixSerializer r e [a] + :: NixSerializer e a + -> NixSerializer e [a] list s = Serializer { getS = do count <- getS int @@ -428,8 +375,8 @@ list s = Serializer set :: Ord a - => NixSerializer r e a - -> NixSerializer r e (Set a) + => NixSerializer e a + -> NixSerializer e (Set a) set = mapIsoSerializer Data.Set.fromList @@ -440,30 +387,36 @@ hashSet :: ( Eq a , Hashable a ) - => NixSerializer r e a - -> NixSerializer r e (HashSet a) + => NixSerializer e a + -> NixSerializer e (HashSet a) hashSet = mapIsoSerializer Data.HashSet.fromList Data.HashSet.toList . list -mapS +mapS' :: Ord k - => NixSerializer r e k - -> NixSerializer r e v - -> NixSerializer r e (Map k v) -mapS k v = + => NixSerializer e (k, v) + -> NixSerializer e (Map k v) +mapS' kv = mapIsoSerializer Data.Map.Strict.fromList Data.Map.Strict.toList $ list - $ tup k v + $ kv + +mapS + :: Ord k + => NixSerializer e k + -> NixSerializer e v + -> NixSerializer e (Map k v) +mapS k v = mapS' $ tup k v vector :: Ord a - => NixSerializer r e a - -> NixSerializer r e (Vector a) + => NixSerializer e a + -> NixSerializer e (Vector a) vector = mapIsoSerializer Data.Vector.fromList @@ -474,23 +427,31 @@ json :: ( FromJSON a , ToJSON a ) - => NixSerializer r SError a -json = - mapPrismSerializer - ( Data.Bifunctor.first SError_JSONDecoding - . Data.Aeson.eitherDecode - ) - Data.Aeson.encode + => NixSerializer SError a +json = mapPrismSerializer jsonP $ mapIsoSerializer Data.ByteString.Lazy.fromStrict Data.ByteString.Lazy.toStrict byteString +jsonP + :: ( FromJSON a + , ToJSON a + ) + => AlmostPrism (ExceptT SError) Data.ByteString.Lazy.ByteString a +jsonP = AlmostPrism + ( ExceptT + . Identity + . Data.Bifunctor.first SError_JSONDecoding + . Data.Aeson.eitherDecode + ) + Data.Aeson.encode + -- * ProtoVersion -- protoVersion_major & 0xFF00 -- protoVersion_minor & 0x00FF -protoVersion :: NixSerializer r e ProtoVersion +protoVersion :: NixSerializer e ProtoVersion protoVersion = Serializer { getS = do v <- getS (int @Word32) @@ -506,73 +467,62 @@ protoVersion = Serializer -- * StorePath -storePath :: HasStoreDir r => NixSerializer r SError StorePath -storePath = Serializer - { getS = do - sd <- Control.Monad.Reader.asks hasStoreDir - System.Nix.StorePath.parsePath sd <$> getS byteString - >>= - either - (throwError . SError_Path) - pure - , putS = \p -> do - sd <- Control.Monad.Reader.asks hasStoreDir - putS - byteString - $ System.Nix.StorePath.storePathToRawFilePath sd p +storePath :: StoreDir -> NixSerializer SError StorePath +storePath storeDir = mapPrismSerializer (storePathP storeDir) byteString + +storePathP :: StoreDir -> AlmostPrism (ExceptT SError) ByteString StorePath +storePathP storeDir = AlmostPrism + { _almostPrism_get = + ExceptT + . Identity + . Data.Bifunctor.first SError_Path + . System.Nix.StorePath.parsePath storeDir + , _almostPrism_put = System.Nix.StorePath.storePathToRawFilePath storeDir } maybePath - :: HasStoreDir r - => NixSerializer r SError (Maybe StorePath) -maybePath = Serializer - { getS = do - getS maybeText >>= \case - Nothing -> pure Nothing - Just t -> do - sd <- Control.Monad.Reader.asks hasStoreDir - either - (throwError . SError_Path) - (pure . pure) - $ System.Nix.StorePath.parsePathFromText sd t + :: StoreDir + -> NixSerializer SError (Maybe StorePath) +maybePath storeDir = mapPrismSerializer (maybeAlmostPrism $ storePathP storeDir) maybeByteString - , putS = \case - Nothing -> putS maybeText Nothing - Just p -> do - sd <- Control.Monad.Reader.asks hasStoreDir - putS text $ System.Nix.StorePath.storePathToText sd p - } - -storePathHashPart :: NixSerializer r SError StorePathHashPart +storePathHashPart :: NixSerializer SError StorePathHashPart storePathHashPart = mapIsoSerializer System.Nix.StorePath.unsafeMakeStorePathHashPart System.Nix.StorePath.unStorePathHashPart $ mapPrismSerializer - (Data.Bifunctor.first (pure SError_InvalidNixBase32) - . System.Nix.Base.decodeWith NixBase32) - (System.Nix.Base.encodeWith NixBase32) + (AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first (pure SError_InvalidNixBase32) + . System.Nix.Base.decodeWith NixBase32) + (System.Nix.Base.encodeWith NixBase32) + ) text -storePathName :: NixSerializer r SError StorePathName +storePathName :: NixSerializer SError StorePathName storePathName = mapPrismSerializer - (Data.Bifunctor.first SError_Name - . System.Nix.StorePath.mkStorePathName) - System.Nix.StorePath.unStorePathName + (AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_Name + . System.Nix.StorePath.mkStorePathName) + System.Nix.StorePath.unStorePathName + ) text pathMetadata - :: HasStoreDir r - => NixSerializer r SError (Metadata StorePath) -pathMetadata = Serializer + :: StoreDir + -> NixSerializer SError (Metadata StorePath) +pathMetadata storeDir = Serializer { getS = do - metadataDeriverPath <- getS maybePath + metadataDeriverPath <- getS $ maybePath storeDir digest' <- getS $ digest Base16 let metadataNarHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest' - metadataReferences <- getS $ hashSet storePath + metadataReferences <- getS $ hashSet $ storePath storeDir metadataRegistrationTime <- getS time metadataNarBytes <- (\case @@ -587,19 +537,20 @@ pathMetadata = Serializer pure $ Metadata{..} , putS = \Metadata{..} -> do - putS maybePath metadataDeriverPath + putS (maybePath storeDir) metadataDeriverPath let putNarHash :: DSum HashAlgo Digest - -> SerialT r SError PutM () + -> PutM () putNarHash = \case System.Nix.Hash.HashAlgo_SHA256 :=> d -> putS (digest @SHA256 Base16) d - _ -> throwError SError_NarHashMustBeSHA256 + _ -> error "nar hash must be SHA 256" + -- throwError SError_NarHashMustBeSHA256 putNarHash metadataNarHash - putS (hashSet storePath) metadataReferences + putS (hashSet $ storePath storeDir) metadataReferences putS time metadataRegistrationTime putS int $ Data.Maybe.fromMaybe 0 metadataNarBytes putS storePathTrust metadataTrust @@ -608,21 +559,21 @@ pathMetadata = Serializer } where maybeContentAddress - :: NixSerializer r SError (Maybe ContentAddress) + :: NixSerializer SError (Maybe ContentAddress) maybeContentAddress = mapPrismSerializer - (maybe - (pure Nothing) - $ Data.Bifunctor.bimap - SError_ContentAddress - Just + (maybeAlmostPrism $ AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_ContentAddress . System.Nix.ContentAddress.parseContentAddress + ) + System.Nix.ContentAddress.buildContentAddress ) - (fmap System.Nix.ContentAddress.buildContentAddress) maybeText storePathTrust - :: NixSerializer r SError StorePathTrust + :: NixSerializer SError StorePathTrust storePathTrust = mapIsoSerializer (\case False -> BuiltElsewhere; True -> BuiltLocally) @@ -631,66 +582,81 @@ pathMetadata = Serializer -- * OutputName -outputName :: NixSerializer r SError OutputName +outputName :: NixSerializer SError OutputName outputName = - mapPrismSerializer - (Data.Bifunctor.first SError_Name - . System.Nix.OutputName.mkOutputName) - System.Nix.OutputName.unOutputName - text + mapIsoSerializer + System.Nix.OutputName.OutputName + System.Nix.OutputName.unOutputName + storePathName -- * Signatures signature - :: NixSerializer r SError Signature + :: NixSerializer SError Signature signature = mapPrismSerializer - (Data.Bifunctor.first SError_Signature - . Data.Attoparsec.Text.parseOnly - System.Nix.Signature.signatureParser) - (System.Nix.Signature.signatureToText) + (AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_Signature + . Data.Attoparsec.Text.parseOnly + System.Nix.Signature.signatureParser) + (System.Nix.Signature.signatureToText) + ) text narSignature - :: NixSerializer r SError NarSignature + :: NixSerializer SError NarSignature narSignature = mapPrismSerializer - (Data.Bifunctor.first SError_Signature - . Data.Attoparsec.Text.parseOnly - System.Nix.Signature.narSignatureParser) - (System.Nix.Signature.narSignatureToText) + (AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_Signature + . Data.Attoparsec.Text.parseOnly + System.Nix.Signature.narSignatureParser) + (System.Nix.Signature.narSignatureToText) + ) text -- * Some HashAlgo -someHashAlgo :: NixSerializer r SError (Some HashAlgo) +someHashAlgo :: NixSerializer SError (Some HashAlgo) someHashAlgo = mapPrismSerializer - (Data.Bifunctor.first SError_HashAlgo - . System.Nix.Hash.textToAlgo) - (Data.Some.foldSome System.Nix.Hash.algoToText) + (AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_HashAlgo + . System.Nix.Hash.textToAlgo) + (Data.Some.foldSome System.Nix.Hash.algoToText) + ) text -- * Digest digest - :: forall a r + :: forall a . HashAlgorithm a => BaseEncoding - -> NixSerializer r SError (Digest a) -digest base = - mapIsoSerializer - Data.Coerce.coerce - Data.Coerce.coerce - $ mapPrismSerializer - (Data.Bifunctor.first SError_Digest - . System.Nix.Hash.decodeDigestWith @a base) - (System.Nix.Hash.encodeDigestWith base) - $ text + -> NixSerializer SError (Digest a) +digest base = mapPrismSerializer (digestP base) $ text + +digestP + :: forall a + . HashAlgorithm a + => BaseEncoding + -> AlmostPrism (ExceptT SError) Text (Digest a) +digestP base = AlmostPrism + (ExceptT + . Identity + . Data.Bifunctor.first SError_Digest + . System.Nix.Hash.decodeDigestWith @a base) + (System.Nix.Hash.encodeDigestWith base) -- * DSum HashAlgo Digest -namedDigest :: NixSerializer r SError (DSum HashAlgo Digest) +namedDigest :: NixSerializer SError (DSum HashAlgo Digest) namedDigest = Serializer { getS = do sriHash <- getS text @@ -711,91 +677,83 @@ namedDigest = Serializer } derivationOutput - :: HasStoreDir r - => NixSerializer r SError (DerivationOutput StorePath Text) -derivationOutput = Serializer + :: StoreDir + -> NixSerializer SError FreeformDerivationOutput +derivationOutput storeDir = Serializer { getS = do - path <- getS storePath - hashAlgo <- getS text - hash <- getS text - pure DerivationOutput{..} - , putS = \DerivationOutput{..} -> do - putS storePath path - putS text hashAlgo - putS text hash + rawPath <- getS text + rawMethodHashAlgo <- getS text + rawHash <- getS text + parseRawDerivationOutput storeDir $ RawDerivationOutput {..} + , putS = \output -> do + let RawDerivationOutput {..} = renderRawDerivationOutput storeDir output + putS text rawPath + putS text rawMethodHashAlgo + putS text rawHash } -- * Derivation -derivation - :: HasStoreDir r - => NixSerializer r SError (Derivation StorePath Text) -derivation = Serializer +basicDerivation + :: StoreDir + -> NixSerializer SError (TraditionalDerivation' (Set StorePath) FreeformDerivationOutputs) +basicDerivation storeDir = Serializer { getS = do - outputs <- getS (mapS text derivationOutput) - -- Our type is Derivation, but in Nix - -- the type sent over the wire is BasicDerivation - -- which omits inputDrvs - inputDrvs <- pure mempty - inputSrcs <- getS (set storePath) - - platform <- getS text - builder <- getS text - args <- getS (vector text) - env <- getS (mapS text text) - pure Derivation{..} - , putS = \Derivation{..} -> do - putS (mapS text derivationOutput) outputs - putS (set storePath) inputSrcs - putS text platform - putS text builder - putS (vector text) args - putS (mapS text text) env + anonOutputs <- getS $ mapS' $ tup outputName $ derivationOutput storeDir + anonInputs <- getS $ set $ storePath storeDir + anonPlatform <- getS text + anonBuilder <- getS text + anonArgs <- getS $ vector text + anonEnv <- getS $ mapS text text + pure $ TraditionalDerivation{..} + , putS = \TraditionalDerivation{..} -> do + putS (mapS' $ tup outputName $ derivationOutput storeDir) anonOutputs + putS (set $ storePath storeDir) anonInputs + putS text anonPlatform + putS text anonBuilder + putS (vector text) anonArgs + putS (mapS text text) anonEnv } -- * DerivedPath derivedPathNew - :: HasStoreDir r - => NixSerializer r SError DerivedPath -derivedPathNew = Serializer + :: StoreDir + -> NixSerializer SError DerivedPath +derivedPathNew storeDir = Serializer { getS = do - root <- Control.Monad.Reader.asks hasStoreDir p <- getS text - case System.Nix.DerivedPath.parseDerivedPath root p of + case System.Nix.DerivedPath.parseDerivedPath storeDir p of Left err -> throwError $ SError_DerivedPath err Right x -> pure x , putS = \d -> do - root <- Control.Monad.Reader.asks hasStoreDir - putS text (System.Nix.DerivedPath.derivedPathToText root d) + putS text (System.Nix.DerivedPath.derivedPathToText storeDir d) } derivedPath - :: ( HasProtoVersion r - , HasStoreDir r - ) - => NixSerializer r SError DerivedPath -derivedPath = Serializer - { getS = do - pv <- Control.Monad.Reader.asks hasProtoVersion + :: StoreDir + -> ProtoVersion + -> NixSerializer SError DerivedPath +derivedPath storeDir pv = Serializer + { getS = if pv < ProtoVersion 1 30 - then DerivedPath_Opaque <$> getS storePath - else getS derivedPathNew - , putS = \d -> do - pv <- Control.Monad.Reader.asks hasProtoVersion + then DerivedPath_Opaque <$> getS (storePath storeDir) + else getS $ derivedPathNew storeDir + , putS = \d -> if pv < ProtoVersion 1 30 then case d of - DerivedPath_Opaque p -> putS storePath p - _ -> throwError - $ SError_NotYetImplemented - "DerivedPath_Built" - (ForPV_Older pv) - else putS derivedPathNew d + DerivedPath_Opaque p -> putS (storePath storeDir) p + _ -> error "not yet implemented" + -- throwError + -- $ SError_NotYetImplemented + -- "DerivedPath_Built" + -- (ForPV_Older pv) + else putS (derivedPathNew storeDir) d } -- * Build -buildMode :: NixSerializer r SError BuildMode +buildMode :: NixSerializer SError BuildMode buildMode = enum -- * Logger @@ -810,11 +768,11 @@ data LoggerSError mapPrimE :: Functor m - => SerialT r SError m a - -> SerialT r LoggerSError m a -mapPrimE = mapErrorST LoggerSError_Prim + => ExceptT SError m a + -> ExceptT LoggerSError m a +mapPrimE = withExceptT LoggerSError_Prim -maybeActivity :: NixSerializer r LoggerSError (Maybe Activity) +maybeActivity :: NixSerializer LoggerSError (Maybe Activity) maybeActivity = Serializer { getS = getS (int @Int) >>= \case 0 -> pure Nothing @@ -824,22 +782,22 @@ maybeActivity = Serializer Just act -> putS activity act } -activity :: NixSerializer r LoggerSError Activity +activity :: NixSerializer LoggerSError Activity activity = Serializer { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100)) , putS = putS int . (+100) . fromEnum } -activityID :: NixSerializer r LoggerSError ActivityID +activityID :: NixSerializer LoggerSError ActivityID activityID = mapIsoSerializer ActivityID unActivityID int -activityResult :: NixSerializer r LoggerSError ActivityResult +activityResult :: NixSerializer LoggerSError ActivityResult activityResult = Serializer { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100)) , putS = putS int . (+100) . fromEnum } -field :: NixSerializer r LoggerSError Field +field :: NixSerializer LoggerSError Field field = Serializer { getS = getS (int @Word8) >>= \case 0 -> Field_LogInt <$> getS int @@ -847,10 +805,10 @@ field = Serializer x -> throwError $ LoggerSError_UnknownLogFieldType x , putS = \case Field_LogInt x -> putS int (0 :: Word8) >> putS int x - Field_LogStr x -> putS int (1 :: Word8) >> mapPrimE (putS text x) + Field_LogStr x -> putS int (1 :: Word8) >> putS text x } -trace :: NixSerializer r LoggerSError Trace +trace :: NixSerializer LoggerSError Trace trace = Serializer { getS = do tracePosition <- (\case 0 -> Nothing; x -> Just x) <$> getS (int @Int) @@ -858,10 +816,10 @@ trace = Serializer pure Trace{..} , putS = \Trace{..} -> do putS int $ Data.Maybe.fromMaybe 0 tracePosition - mapPrimE $ putS text traceHint + putS text traceHint } -basicError :: NixSerializer r LoggerSError BasicError +basicError :: NixSerializer LoggerSError BasicError basicError = Serializer { getS = do basicErrorMessage <- mapPrimE $ getS text @@ -869,11 +827,11 @@ basicError = Serializer pure BasicError{..} , putS = \BasicError{..} -> do - mapPrimE $ putS text basicErrorMessage + putS text basicErrorMessage putS int basicErrorExitStatus } -errorInfo :: NixSerializer r LoggerSError ErrorInfo +errorInfo :: NixSerializer LoggerSError ErrorInfo errorInfo = Serializer { getS = do etyp <- mapPrimE $ getS text @@ -888,17 +846,17 @@ errorInfo = Serializer pure ErrorInfo{..} , putS = \ErrorInfo{..} -> do - mapPrimE $ do + do putS text $ Data.Text.pack "Error" putS verbosity errorInfoLevel - mapPrimE $ do + do putS text $ Data.Text.pack "Error" -- removed error name putS text errorInfoMessage putS int $ Data.Maybe.fromMaybe 0 errorInfoPosition putS (list trace) errorInfoTraces } -loggerOpCode :: NixSerializer r LoggerSError LoggerOpCode +loggerOpCode :: NixSerializer LoggerSError LoggerOpCode loggerOpCode = Serializer { getS = do c <- getS int @@ -910,9 +868,9 @@ loggerOpCode = Serializer } logger - :: HasProtoVersion r - => NixSerializer r LoggerSError Logger -logger = Serializer + :: ProtoVersion + -> NixSerializer LoggerSError Logger +logger pv = Serializer { getS = getS loggerOpCode >>= \case LoggerOpCode_Next -> mapPrimE $ @@ -929,7 +887,6 @@ logger = Serializer pure Logger_Last LoggerOpCode_Error -> do - pv <- Control.Monad.Reader.asks hasProtoVersion Logger_Error <$> if protoVersion_minor pv >= 26 then Right <$> getS errorInfo @@ -957,7 +914,7 @@ logger = Serializer , putS = \case Logger_Next s -> do putS loggerOpCode LoggerOpCode_Next - mapPrimE $ putS text s + putS text s Logger_Read i -> do putS loggerOpCode LoggerOpCode_Read @@ -965,7 +922,7 @@ logger = Serializer Logger_Write s -> do putS loggerOpCode LoggerOpCode_Write - mapPrimE $ putS byteString s + putS byteString s Logger_Last -> putS loggerOpCode LoggerOpCode_Last @@ -973,12 +930,12 @@ logger = Serializer Logger_Error basicOrInfo -> do putS loggerOpCode LoggerOpCode_Error - minor <- protoVersion_minor <$> Control.Monad.Reader.asks hasProtoVersion + let minor = protoVersion_minor pv case basicOrInfo of - Left _ | minor >= 26 -> throwError $ LoggerSError_TooNewForBasicError + Left _ | minor >= 26 -> error "protocol too new" -- throwError $ LoggerSError_TooNewForBasicError Left e | otherwise -> putS basicError e - Right _ | minor < 26 -> throwError $ LoggerSError_TooOldForErrorInfo + Right _ | minor < 26 -> error "protocol too old" -- throwError $ LoggerSError_TooOldForErrorInfo Right e -> putS errorInfo e Logger_StartActivity{..} -> do @@ -986,8 +943,7 @@ logger = Serializer putS activityID startActivityID putS verbosity startActivityVerbosity putS maybeActivity startActivityType - mapPrimE $ - putS byteString startActivityString + putS byteString startActivityString putS (list field) startActivityFields putS activityID startActivityParentID @@ -1002,10 +958,10 @@ logger = Serializer putS (list field) resultFields } -verbosity :: NixSerializer r LoggerSError Verbosity +verbosity :: NixSerializer LoggerSError Verbosity verbosity = Serializer { getS = mapPrimE $ getS enum - , putS = mapPrimE . putS enum + , putS = putS enum } -- * Handshake @@ -1015,7 +971,7 @@ data HandshakeSError | HandshakeSError_InvalidTrustedFlag Word8 deriving (Eq, Ord, Generic, Show) -workerMagic :: NixSerializer r HandshakeSError WorkerMagic +workerMagic :: NixSerializer HandshakeSError WorkerMagic workerMagic = Serializer { getS = do c <- getS int @@ -1026,7 +982,7 @@ workerMagic = Serializer , putS = putS int . workerMagicToWord64 } -trustedFlag :: NixSerializer r HandshakeSError (Maybe TrustedFlag) +trustedFlag :: NixSerializer HandshakeSError (Maybe TrustedFlag) trustedFlag = Serializer { getS = do n :: Word8 <- getS int @@ -1043,7 +999,7 @@ trustedFlag = Serializer -- * Worker protocol -storeText :: NixSerializer r SError StoreText +storeText :: NixSerializer SError StoreText storeText = Serializer { getS = do storeTextName <- getS storePathName @@ -1054,7 +1010,7 @@ storeText = Serializer putS text storeTextText } -workerOp :: NixSerializer r SError WorkerOp +workerOp :: NixSerializer SError WorkerOp workerOp = enum -- * Request @@ -1063,17 +1019,15 @@ data RequestSError = RequestSError_NotYetImplemented WorkerOp | RequestSError_ReservedOp WorkerOp | RequestSError_PrimGet SError - | RequestSError_PrimPut SError | RequestSError_PrimWorkerOp SError deriving (Eq, Ord, Generic, Show) storeRequest - :: ( HasProtoVersion r - , HasStoreDir r - ) - => NixSerializer r RequestSError (Some StoreRequest) -storeRequest = Serializer - { getS = mapErrorST RequestSError_PrimWorkerOp (getS workerOp) >>= \case + :: StoreDir + -> ProtoVersion + -> NixSerializer RequestSError (Some StoreRequest) +storeRequest storeDir pv = Serializer + { getS = withExceptT RequestSError_PrimWorkerOp (getS workerOp) >>= \case WorkerOp_AddToStore -> mapGetE $ do pathName <- getS storePathName _fixed <- getS bool -- obsolete @@ -1086,8 +1040,8 @@ storeRequest = Serializer pure $ Some (AddToStore pathName recursive hashAlgo repair) WorkerOp_AddToStoreNar -> mapGetE $ do - storePath' <- getS storePath - metadata <- getS pathMetadata + storePath' <- getS $ storePath storeDir + metadata <- getS $ pathMetadata storeDir repair <- getS bool let repairMode = if repair then RepairMode_DoRepair else RepairMode_DontRepair dontCheckSigs <- getS bool @@ -1097,35 +1051,39 @@ storeRequest = Serializer WorkerOp_AddTextToStore -> mapGetE $ do txt <- getS storeText - paths <- getS (hashSet storePath) + paths <- getS $ hashSet $ storePath storeDir let repair = RepairMode_DontRepair pure $ Some (AddTextToStore txt paths repair) WorkerOp_AddSignatures -> mapGetE $ do - path <- getS storePath + path <- getS $ storePath storeDir signatures <- getS (set signature) pure $ Some (AddSignatures path signatures) WorkerOp_AddIndirectRoot -> mapGetE $ do - Some . AddIndirectRoot <$> getS storePath + Some . AddIndirectRoot <$> getS (storePath storeDir) WorkerOp_AddTempRoot -> mapGetE $ do - Some . AddTempRoot <$> getS storePath + Some . AddTempRoot <$> getS (storePath storeDir) WorkerOp_BuildPaths -> mapGetE $ do - derived <- getS (set derivedPath) + derived <- getS (set $ derivedPath storeDir pv) buildMode' <- getS buildMode pure $ Some (BuildPaths derived buildMode') WorkerOp_BuildDerivation -> mapGetE $ do - path <- getS storePath - drv <- getS derivation + path <- getS $ storePath storeDir + let name = System.Nix.StorePath.storePathName path + drv0 <- getS $ basicDerivation storeDir + let drv1 = withName name drv0 + outputs <- toSpecificOutputs storeDir name $ outputs drv1 + let drv2 = drv1 { outputs = outputs } buildMode' <- getS buildMode - pure $ Some (BuildDerivation path drv buildMode') + pure $ Some (BuildDerivation path drv2 buildMode') WorkerOp_CollectGarbage -> mapGetE $ do gcOptionsOperation <- getS enum - gcOptionsPathsToDelete <- getS (hashSet storePath) + gcOptionsPathsToDelete <- getS (hashSet $ storePath storeDir) gcOptionsIgnoreLiveness <- getS bool gcOptionsMaxFreed <- getS int -- obsolete fields @@ -1134,19 +1092,19 @@ storeRequest = Serializer pure $ Some (CollectGarbage GCOptions{..}) WorkerOp_EnsurePath -> mapGetE $ do - Some . EnsurePath <$> getS storePath + Some . EnsurePath <$> getS (storePath storeDir) WorkerOp_FindRoots -> mapGetE $ do pure $ Some FindRoots WorkerOp_IsValidPath -> mapGetE $ do - Some . IsValidPath <$> getS storePath + Some . IsValidPath <$> getS (storePath storeDir) WorkerOp_NarFromPath -> mapGetE $ do - Some . NarFromPath <$> getS storePath + Some . NarFromPath <$> getS (storePath storeDir) WorkerOp_QueryValidPaths -> mapGetE $ do - paths <- getS (hashSet storePath) + paths <- getS (hashSet $ storePath storeDir) substituteMode <- getS enum pure $ Some (QueryValidPaths paths substituteMode) @@ -1154,28 +1112,28 @@ storeRequest = Serializer pure $ Some QueryAllValidPaths WorkerOp_QuerySubstitutablePaths -> mapGetE $ do - Some . QuerySubstitutablePaths <$> getS (hashSet storePath) + Some . QuerySubstitutablePaths <$> getS (hashSet $ storePath storeDir) WorkerOp_QueryPathInfo -> mapGetE $ do - Some . QueryPathInfo <$> getS storePath + Some . QueryPathInfo <$> getS (storePath storeDir) WorkerOp_QueryReferrers -> mapGetE $ do - Some . QueryReferrers <$> getS storePath + Some . QueryReferrers <$> getS (storePath storeDir) WorkerOp_QueryValidDerivers -> mapGetE $ do - Some . QueryValidDerivers <$> getS storePath + Some . QueryValidDerivers <$> getS (storePath storeDir) WorkerOp_QueryDerivationOutputs -> mapGetE $ do - Some . QueryDerivationOutputs <$> getS storePath + Some . QueryDerivationOutputs <$> getS (storePath storeDir) WorkerOp_QueryDerivationOutputNames -> mapGetE $ do - Some . QueryDerivationOutputNames <$> getS storePath + Some . QueryDerivationOutputNames <$> getS (storePath storeDir) WorkerOp_QueryPathFromHashPart -> mapGetE $ do Some . QueryPathFromHashPart <$> getS storePathHashPart WorkerOp_QueryMissing -> mapGetE $ do - Some . QueryMissing <$> getS (set derivedPath) + Some . QueryMissing <$> getS (set $ derivedPath storeDir pv) WorkerOp_OptimiseStore -> mapGetE $ do pure $ Some OptimiseStore @@ -1213,7 +1171,7 @@ storeRequest = Serializer w@WorkerOp_SetOptions -> notYet w , putS = \case - Some (AddToStore pathName recursive hashAlgo _repair) -> mapPutE $ do + Some (AddToStore pathName recursive hashAlgo _repair) -> do putS workerOp WorkerOp_AddToStore putS storePathName pathName @@ -1226,121 +1184,123 @@ storeRequest = Serializer putS bool (recursive == FileIngestionMethod_NixArchive) putS someHashAlgo hashAlgo - Some (AddToStoreNar storePath' metadata repair checkSigs) -> mapPutE $ do + Some (AddToStoreNar storePath' metadata repair checkSigs) -> do putS workerOp WorkerOp_AddToStoreNar - putS storePath storePath' - putS pathMetadata metadata + putS (storePath storeDir) storePath' + putS (pathMetadata storeDir) metadata putS bool $ repair == RepairMode_DoRepair putS bool $ checkSigs == CheckMode_DontCheck - Some (AddTextToStore txt paths _repair) -> mapPutE $ do + Some (AddTextToStore txt paths _repair) -> do putS workerOp WorkerOp_AddTextToStore putS storeText txt - putS (hashSet storePath) paths + putS (hashSet $ storePath storeDir) paths - Some (AddSignatures path signatures) -> mapPutE $ do + Some (AddSignatures path signatures) -> do putS workerOp WorkerOp_AddSignatures - putS storePath path + putS (storePath storeDir) path putS (set signature) signatures - Some (AddIndirectRoot path) -> mapPutE $ do + Some (AddIndirectRoot path) -> do putS workerOp WorkerOp_AddIndirectRoot - putS storePath path + putS (storePath storeDir) path - Some (AddTempRoot path) -> mapPutE $ do + Some (AddTempRoot path) -> do putS workerOp WorkerOp_AddTempRoot - putS storePath path + putS (storePath storeDir) path - Some (BuildPaths derived buildMode') -> mapPutE $ do + Some (BuildPaths derived buildMode') -> do putS workerOp WorkerOp_BuildPaths - putS (set derivedPath) derived + putS (set $ derivedPath storeDir pv) derived putS buildMode buildMode' - Some (BuildDerivation path drv buildMode') -> mapPutE $ do + Some (BuildDerivation path drv0 buildMode') -> do putS workerOp WorkerOp_BuildDerivation - putS storePath path - putS derivation drv + putS (storePath storeDir) path + let drv1 = drv0 { outputs = fromSpecificOutputs storeDir (name drv0) $ outputs drv0 } + let drv2 = withoutName drv1 + putS (basicDerivation storeDir) drv2 putS buildMode buildMode' - Some (CollectGarbage GCOptions{..}) -> mapPutE $ do + Some (CollectGarbage GCOptions{..}) -> do putS workerOp WorkerOp_CollectGarbage putS enum gcOptionsOperation - putS (hashSet storePath) gcOptionsPathsToDelete + putS (hashSet $ storePath storeDir) gcOptionsPathsToDelete putS bool gcOptionsIgnoreLiveness putS int gcOptionsMaxFreed -- obsolete fields Control.Monad.forM_ [0..(2 :: Word8)] $ pure $ putS int (0 :: Word8) - Some (EnsurePath path) -> mapPutE $ do + Some (EnsurePath path) -> do putS workerOp WorkerOp_EnsurePath - putS storePath path + putS (storePath storeDir) path - Some FindRoots -> mapPutE $ do + Some FindRoots -> do putS workerOp WorkerOp_FindRoots - Some (IsValidPath path) -> mapPutE $ do + Some (IsValidPath path) -> do putS workerOp WorkerOp_IsValidPath - putS storePath path + putS (storePath storeDir) path - Some (NarFromPath path) -> mapPutE $ do + Some (NarFromPath path) -> do putS workerOp WorkerOp_NarFromPath - putS storePath path + putS (storePath storeDir) path - Some (QueryValidPaths paths substituteMode) -> mapPutE $ do + Some (QueryValidPaths paths substituteMode) -> do putS workerOp WorkerOp_QueryValidPaths - putS (hashSet storePath) paths + putS (hashSet $ storePath storeDir) paths putS enum substituteMode - Some QueryAllValidPaths -> mapPutE $ do + Some QueryAllValidPaths -> do putS workerOp WorkerOp_QueryAllValidPaths - Some (QuerySubstitutablePaths paths) -> mapPutE $ do + Some (QuerySubstitutablePaths paths) -> do putS workerOp WorkerOp_QuerySubstitutablePaths - putS (hashSet storePath) paths + putS (hashSet $ storePath storeDir) paths - Some (QueryPathInfo path) -> mapPutE $ do + Some (QueryPathInfo path) -> do putS workerOp WorkerOp_QueryPathInfo - putS storePath path + putS (storePath storeDir) path - Some (QueryReferrers path) -> mapPutE $ do + Some (QueryReferrers path) -> do putS workerOp WorkerOp_QueryReferrers - putS storePath path + putS (storePath storeDir) path - Some (QueryValidDerivers path) -> mapPutE $ do + Some (QueryValidDerivers path) -> do putS workerOp WorkerOp_QueryValidDerivers - putS storePath path + putS (storePath storeDir) path - Some (QueryDerivationOutputs path) -> mapPutE $ do + Some (QueryDerivationOutputs path) -> do putS workerOp WorkerOp_QueryDerivationOutputs - putS storePath path + putS (storePath storeDir) path - Some (QueryDerivationOutputNames path) -> mapPutE $ do + Some (QueryDerivationOutputNames path) -> do putS workerOp WorkerOp_QueryDerivationOutputNames - putS storePath path + putS (storePath storeDir) path - Some (QueryPathFromHashPart pathHashPart) -> mapPutE $ do + Some (QueryPathFromHashPart pathHashPart) -> do putS workerOp WorkerOp_QueryPathFromHashPart putS storePathHashPart pathHashPart - Some (QueryMissing derived) -> mapPutE $ do + Some (QueryMissing derived) -> do putS workerOp WorkerOp_QueryMissing - putS (set derivedPath) derived + putS (set $ derivedPath storeDir pv) derived - Some OptimiseStore -> mapPutE $ do + Some OptimiseStore -> do putS workerOp WorkerOp_OptimiseStore - Some SyncWithGC -> mapPutE $ do + Some SyncWithGC -> do putS workerOp WorkerOp_SyncWithGC - Some (VerifyStore checkMode repairMode) -> mapPutE $ do + Some (VerifyStore checkMode repairMode) -> do putS workerOp WorkerOp_VerifyStore putS enum checkMode putS enum repairMode @@ -1348,15 +1308,9 @@ storeRequest = Serializer where mapGetE :: Functor m - => SerialT r SError m a - -> SerialT r RequestSError m a - mapGetE = mapErrorST RequestSError_PrimGet - - mapPutE - :: Functor m - => SerialT r SError m a - -> SerialT r RequestSError m a - mapPutE = mapErrorST RequestSError_PrimPut + => ExceptT SError m a + -> ExceptT RequestSError m a + mapGetE = withExceptT RequestSError_PrimGet notYet :: MonadError RequestSError m @@ -1374,8 +1328,7 @@ storeRequest = Serializer data ReplySError = ReplySError_PrimGet SError - | ReplySError_PrimPut SError - | ReplySError_DerivationOutput SError + | ReplySError_BuildTraceKey SError | ReplySError_GCResult SError | ReplySError_Metadata SError | ReplySError_Missing SError @@ -1386,20 +1339,14 @@ data ReplySError mapGetER :: Functor m - => SerialT r SError m a - -> SerialT r ReplySError m a -mapGetER = mapErrorST ReplySError_PrimGet - -mapPutER - :: Functor m - => SerialT r SError m a - -> SerialT r ReplySError m a -mapPutER = mapErrorST ReplySError_PrimPut + => ExceptT SError m a + -> ExceptT ReplySError m a +mapGetER = withExceptT ReplySError_PrimGet -- | Parse a bool returned at the end of simple operations. -- This is always 1 (@True@) so we assert that it really is so. -- Errors for these operations are indicated via @Logger_Error@. -opSuccess :: NixSerializer r ReplySError SuccessCodeReply +opSuccess :: NixSerializer ReplySError SuccessCodeReply opSuccess = Serializer { getS = do retCode <- mapGetER $ getS bool @@ -1407,10 +1354,10 @@ opSuccess = Serializer (retCode == True) $ throwError ReplySError_UnexpectedFalseOpSuccess pure SuccessCodeReply - , putS = \_ -> mapPutER $ putS bool True + , putS = \_ -> putS bool True } -noop :: a -> NixSerializer r ReplySError a +noop :: a -> NixSerializer ReplySError a noop ret = Serializer { getS = pure ret , putS = \_ -> pure () @@ -1418,37 +1365,38 @@ noop ret = Serializer -- *** Realisation -derivationOutputTyped :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName) -derivationOutputTyped = mapErrorS ReplySError_DerivationOutput $ +buildTraceKeyTyped :: NixSerializer ReplySError (System.Nix.Realisation.BuildTraceKey OutputName) +buildTraceKeyTyped = mapErrorS ReplySError_BuildTraceKey $ mapPrismSerializer - ( Data.Bifunctor.first SError_DerivationOutput - . System.Nix.Realisation.derivationOutputParser + AlmostPrism + { _almostPrism_get = + ExceptT + . Identity + . Data.Bifunctor.first SError_BuildTraceKey + . System.Nix.Realisation.buildTraceKeyParser System.Nix.OutputName.mkOutputName - ) - ( Data.Text.Lazy.toStrict + , _almostPrism_put = + Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText - . System.Nix.Realisation.derivationOutputBuilder - System.Nix.OutputName.unOutputName - ) + . System.Nix.Realisation.buildTraceKeyBuilder + (System.Nix.StorePath.unStorePathName . System.Nix.OutputName.unOutputName) + } text -realisation :: NixSerializer r ReplySError Realisation +realisation :: NixSerializer ReplySError Realisation realisation = mapErrorS ReplySError_Realisation json -realisationWithId :: NixSerializer r ReplySError RealisationWithId +realisationWithId :: NixSerializer ReplySError RealisationWithId realisationWithId = mapErrorS ReplySError_RealisationWithId json -- *** BuildResult buildResult - :: ( HasProtoVersion r - , HasStoreDir r - ) - => NixSerializer r ReplySError BuildResult -buildResult = Serializer + :: StoreDir + -> ProtoVersion + -> NixSerializer ReplySError BuildResult +buildResult storeDir pv = Serializer { getS = do - pv <- Control.Monad.Reader.asks hasProtoVersion - buildResultStatus <- mapGetER $ getS enum buildResultErrorMessage <- mapGetER $ getS maybeText @@ -1473,22 +1421,20 @@ buildResult = Serializer . Data.Map.Strict.fromList . map (\(_, RealisationWithId (a, b)) -> (a, b)) . Data.Map.Strict.toList - <$> getS (mapS derivationOutputTyped realisationWithId) + <$> getS (mapS buildTraceKeyTyped realisationWithId) else pure Nothing pure BuildResult{..} , putS = \BuildResult{..} -> do - pv <- Control.Monad.Reader.asks hasProtoVersion - - mapPutER $ putS enum buildResultStatus - mapPutER $ putS maybeText buildResultErrorMessage - Control.Monad.when (protoVersion_minor pv >= 29) $ mapPutER $ do + putS enum buildResultStatus + putS maybeText buildResultErrorMessage + Control.Monad.when (protoVersion_minor pv >= 29) $ do putS int $ Data.Maybe.fromMaybe 0 buildResultTimesBuilt putS bool $ Data.Maybe.fromMaybe False buildResultIsNonDeterministic putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime Control.Monad.when (protoVersion_minor pv >= 28) - $ putS (mapS derivationOutputTyped realisationWithId) + $ putS (mapS buildTraceKeyTyped realisationWithId) $ Data.Map.Strict.fromList $ map (\(a, b) -> (a, RealisationWithId (a, b))) $ Data.Map.Strict.toList @@ -1501,29 +1447,29 @@ buildResult = Serializer -- *** GCResult gcResult - :: HasStoreDir r - => NixSerializer r ReplySError GCResult -gcResult = mapErrorS ReplySError_GCResult $ Serializer + :: StoreDir + -> NixSerializer ReplySError GCResult +gcResult storeDir = mapErrorS ReplySError_GCResult $ Serializer { getS = do - gcResultDeletedPaths <- getS (hashSet storePath) + gcResultDeletedPaths <- getS (hashSet $ storePath storeDir) gcResultBytesFreed <- getS int Control.Monad.void $ getS (int @Word64) -- obsolete pure GCResult{..} , putS = \GCResult{..} -> do - putS (hashSet storePath) gcResultDeletedPaths + putS (hashSet $ storePath storeDir) gcResultDeletedPaths putS int gcResultBytesFreed putS (int @Word64) 0 -- obsolete } -- *** GCRoot -gcRoot :: NixSerializer r ReplySError GCRoot +gcRoot :: NixSerializer ReplySError GCRoot gcRoot = Serializer { getS = mapGetER $ do getS byteString >>= \case p | p == censored -> pure GCRoot_Censored p -> pure (GCRoot_Path p) - , putS = mapPutER . putS byteString . \case + , putS = putS byteString . \case GCRoot_Censored -> censored GCRoot_Path p -> p } @@ -1532,21 +1478,21 @@ gcRoot = Serializer -- *** Missing missing - :: HasStoreDir r - => NixSerializer r ReplySError Missing -missing = mapErrorS ReplySError_Missing $ Serializer + :: StoreDir + -> NixSerializer ReplySError Missing +missing storeDir = mapErrorS ReplySError_Missing $ Serializer { getS = do - missingWillBuild <- getS (hashSet storePath) - missingWillSubstitute <- getS (hashSet storePath) - missingUnknownPaths <- getS (hashSet storePath) + missingWillBuild <- getS (hashSet $ storePath storeDir) + missingWillSubstitute <- getS (hashSet $ storePath storeDir) + missingUnknownPaths <- getS (hashSet $ storePath storeDir) missingDownloadSize <- getS int missingNarSize <- getS int pure Missing{..} , putS = \Missing{..} -> do - putS (hashSet storePath) missingWillBuild - putS (hashSet storePath) missingWillSubstitute - putS (hashSet storePath) missingUnknownPaths + putS (hashSet $ storePath storeDir) missingWillBuild + putS (hashSet $ storePath storeDir) missingWillSubstitute + putS (hashSet $ storePath storeDir) missingUnknownPaths putS int missingDownloadSize putS int missingNarSize } @@ -1554,15 +1500,15 @@ missing = mapErrorS ReplySError_Missing $ Serializer -- *** Maybe (Metadata StorePath) maybePathMetadata - :: HasStoreDir r - => NixSerializer r ReplySError (Maybe (Metadata StorePath)) -maybePathMetadata = mapErrorS ReplySError_Metadata $ Serializer + :: StoreDir + -> NixSerializer ReplySError (Maybe (Metadata StorePath)) +maybePathMetadata storeDir = mapErrorS ReplySError_Metadata $ Serializer { getS = do valid <- getS bool if valid - then pure <$> getS pathMetadata + then pure <$> getS (pathMetadata storeDir) else pure Nothing , putS = \case Nothing -> putS bool False - Just pm -> putS bool True >> putS pathMetadata pm + Just pm -> putS bool True >> putS (pathMetadata storeDir) pm } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs index 47557b73..1c61349b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs @@ -21,25 +21,26 @@ import Data.Word (Word32) import Network.Socket (Socket, accept, close, listen, maxListenQueue) import System.Nix.Nar (NarSource) import System.Nix.Store.Remote.Client (Run, doReq) -import System.Nix.Store.Remote.Serializer (LoggerSError, mapErrorS, storeRequest, workerMagic, protoVersion, int, logger, text, trustedFlag) +import System.Nix.Store.Remote.Serializer + --(LoggerSError, mapErrorS, storeRequest, workerMagic, protoVersion, int, logger, text, trustedFlag) import System.Nix.Store.Remote.Socket +import System.Nix.Store.Remote.Types.NoReply import System.Nix.Store.Remote.Types.StoreRequest as R -import System.Nix.Store.Remote.Types.StoreReply import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..)) import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..)) import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT) import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), ServerHandshakeOutput(..)) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) -import qualified Data.Some -import qualified Data.Text -import qualified Data.Text.IO -import qualified System.Timeout -import qualified Network.Socket.ByteString +import Data.Some qualified +import Data.Text qualified +import Data.Text.IO qualified +import System.Timeout qualified +import Network.Socket.ByteString qualified type WorkerHelper m = forall a . ( Show a - , StoreReply a + --, StoreReply a ) => RemoteStoreT m a -> Run m a @@ -116,7 +117,7 @@ processConnection workerHelper postGreet sock = do let perform :: ( Show a - , StoreReply a + --, StoreReply a ) => StoreRequest a -> RemoteStoreT m () @@ -149,21 +150,55 @@ processConnection workerHelper postGreet sock = do case fst res of Left e -> throwError e - Right reply -> + Right reply -> do + sd <- getStoreDir + pv <- getProtoVersion + let + mapE = mapErrorS ReplySError_PrimGet + storePath' = mapE $ storePath sd sockPutS (mapErrorS RemoteStoreError_SerializerReply - $ getReplyS + -- no guarantee we always return the same type in the same way across different commands; type class is not recommended. + $ case req of + AddToStore {} -> storePath' + AddToStoreNar {} -> noop NoReply + AddTextToStore {} -> storePath' + AddSignatures {} -> opSuccess + AddTempRoot {} -> opSuccess + AddIndirectRoot {} -> opSuccess + BuildDerivation {} -> buildResult sd pv + BuildPaths {} -> opSuccess + CollectGarbage {} -> gcResult sd + EnsurePath {} -> opSuccess + FindRoots {} -> mapS gcRoot $ storePath' + IsValidPath {} -> mapE bool + NarFromPath {} -> noop NoReply + QueryValidPaths {} -> hashSet storePath' + QueryAllValidPaths {} -> hashSet storePath' + QuerySubstitutablePaths {} -> hashSet $ storePath' + QueryPathInfo {} -> maybePathMetadata sd + QueryReferrers {} -> hashSet storePath' + QueryValidDerivers {} -> hashSet storePath' + QueryDerivationOutputs {} -> hashSet storePath' + QueryDerivationOutputNames {} -> mapE $ hashSet $ storePathName + QueryPathFromHashPart {} -> storePath' + QueryMissing {} -> missing sd + OptimiseStore {} -> opSuccess + SyncWithGC {} -> opSuccess + VerifyStore {} -> mapE bool ) reply -- Process client requests. let loop = do + sd <- getStoreDir + pv <- getProtoVersion someReq <- sockGetS $ mapErrorS RemoteStoreError_SerializerRequest - storeRequest + $ storeRequest sd pv -- have to be explicit here -- because otherwise GHC can't conjure Show a, StoreReply a @@ -305,9 +340,11 @@ enqueueMsg => TunnelLogger -> Logger -> m () -enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of - True -> (st, sockPutS logger l) - False -> (TunnelLoggerState c (l:p), pure ()) +enqueueMsg x l = do + pv <- getProtoVersion + updateLogger x $ \st@(TunnelLoggerState c p) -> case c of + True -> (st, sockPutS (logger pv) l) + False -> (TunnelLoggerState c (l:p), pure ()) _log :: ( MonadRemoteStore m @@ -322,18 +359,23 @@ startWork :: MonadRemoteStore m => TunnelLogger -> m () -startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,) - (TunnelLoggerState True []) $ - (traverse_ (sockPutS logger') $ reverse p) - where logger' = mapErrorS RemoteStoreError_SerializerLogger logger +startWork x = do + pv <- getProtoVersion + let logger' = mapErrorS RemoteStoreError_SerializerLogger $ logger pv + updateLogger x $ \(TunnelLoggerState _ p) -> (,) + (TunnelLoggerState True []) $ + (traverse_ (sockPutS logger') $ reverse p) stopWork :: MonadRemoteStore m => TunnelLogger -> m () -stopWork x = updateLogger x $ \_ -> (,) - (TunnelLoggerState False []) - (sockPutS (mapErrorS RemoteStoreError_SerializerLogger logger) Logger_Last) +stopWork x = do + pv <- getProtoVersion + let logger' = mapErrorS RemoteStoreError_SerializerLogger $ logger pv + updateLogger x $ \_ -> (,) + (TunnelLoggerState False []) + (sockPutS logger' Logger_Last) -- | Stop sending logging and report an error. -- @@ -351,11 +393,12 @@ _stopWorkOnError x ex = updateLogger x $ \st -> case _tunnelLoggerState_canSendStderr st of False -> (st, pure False) True -> (,) (TunnelLoggerState False []) $ do - getProtoVersion >>= \pv -> if protoVersion_minor pv >= 26 + pv <- getProtoVersion + let logger' = mapErrorS RemoteStoreError_SerializerLogger $ logger pv + if protoVersion_minor pv >= 26 then sockPutS logger' (Logger_Error (Right ex)) else sockPutS logger' (Logger_Error (Left (BasicError 0 (Data.Text.pack $ show ex)))) pure True - where logger' = mapErrorS RemoteStoreError_SerializerLogger logger updateLogger :: MonadRemoteStore m diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs index 8c321529..46ed9085 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -1,19 +1,19 @@ module System.Nix.Store.Remote.Socket where import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Trans.Except (runExceptT) import Control.Monad.IO.Class (MonadIO(..)) import Data.ByteString (ByteString) import Data.Serialize.Get (Get, Result(..)) import Data.Serialize.Put (Put, runPut) import Network.Socket.ByteString (recv, sendAll) import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), RemoteStoreError(..)) -import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT) -import System.Nix.Store.Remote.Types (ProtoStoreConfig) +import System.Nix.Store.Remote.Serializer (NixSerializer, runP) -import qualified Control.Exception -import qualified Data.ByteString -import qualified Data.Serializer -import qualified Data.Serialize.Get +import Control.Exception qualified +import Data.ByteString qualified +import Data.Serializer qualified +import Data.Serialize.Get qualified genericIncremental :: ( MonadIO m @@ -73,15 +73,13 @@ sockPutS :: ( MonadRemoteStore m , MonadError e m ) - => NixSerializer ProtoStoreConfig e a + => NixSerializer e a -> a -> m () sockPutS s a = do - cfg <- getConfig sock <- getStoreSocket - case runP s cfg a of - Right x -> liftIO $ sendAll sock x - Left e -> throwError e + let x = runP s a + liftIO $ sendAll sock x sockGetS :: ( MonadRemoteStore m @@ -89,12 +87,11 @@ sockGetS , Show a , Show e ) - => NixSerializer ProtoStoreConfig e a + => NixSerializer e a -> m a sockGetS s = do - cfg <- getConfig res <- genericIncremental sockGet8 - $ runSerialT cfg $ Data.Serializer.getS s + $ runExceptT $ Data.Serializer.getS s case res of Right x -> pure x diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs deleted file mode 100644 index 33108210..00000000 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ /dev/null @@ -1,61 +0,0 @@ -module System.Nix.Store.Remote.Types.StoreReply - ( StoreReply(..) - ) where - -import Data.HashSet (HashSet) -import Data.Map (Map) -import System.Nix.Build (BuildResult) -import System.Nix.StorePath (StorePath, StorePathName) -import System.Nix.StorePath.Metadata (Metadata) -import System.Nix.Store.Remote.Serializer -import System.Nix.Store.Remote.Types.NoReply (NoReply(..)) -import System.Nix.Store.Remote.Types.SuccessCodeReply (SuccessCodeReply) -import System.Nix.Store.Remote.Types.GC (GCResult, GCRoot) -import System.Nix.Store.Remote.Types.Query.Missing (Missing) -import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig) - --- | Get @NixSerializer@ for some type @a@ --- This could also be generalized for every type --- we have a serializer for but we mostly need --- this for replies and it would make look serializers --- quite hodor, like @a <- getS get; b <- getS get@ -class StoreReply a where - getReplyS :: NixSerializer ProtoStoreConfig ReplySError a - -instance StoreReply SuccessCodeReply where - getReplyS = opSuccess - -instance StoreReply NoReply where - getReplyS = noop NoReply - -instance StoreReply Bool where - getReplyS = mapPrimE bool - -instance StoreReply BuildResult where - getReplyS = buildResult - -instance StoreReply GCResult where - getReplyS = gcResult - -instance StoreReply (Map GCRoot StorePath) where - getReplyS = mapS gcRoot (mapPrimE storePath) - -instance StoreReply Missing where - getReplyS = missing - -instance StoreReply (Maybe (Metadata StorePath)) where - getReplyS = maybePathMetadata - -instance StoreReply StorePath where - getReplyS = mapPrimE storePath - -instance StoreReply (HashSet StorePath) where - getReplyS = mapPrimE (hashSet storePath) - -instance StoreReply (HashSet StorePathName) where - getReplyS = mapPrimE (hashSet storePathName) - -mapPrimE - :: NixSerializer r SError a - -> NixSerializer r ReplySError a -mapPrimE = mapErrorS ReplySError_PrimGet diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs index 542ddcbd..77338a44 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -12,11 +12,10 @@ import Data.HashSet (HashSet) import Data.Kind (Type) import Data.Map (Map) import Data.Set (Set) -import Data.Text (Text) import Data.Some (Some(Some)) import System.Nix.Build (BuildMode, BuildResult) -import System.Nix.Derivation (Derivation) +import System.Nix.Derivation (BasicDerivation) import System.Nix.DerivedPath (DerivedPath) import System.Nix.Hash (HashAlgo) import System.Nix.Signature (Signature) @@ -85,7 +84,7 @@ data StoreRequest :: Type -> Type where BuildDerivation :: StorePath - -> Derivation StorePath Text + -> BasicDerivation -> BuildMode -> StoreRequest BuildResult diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs index 1839fad4..0b3040ac 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs @@ -1,4 +1,4 @@ -module System.Nix.Store.Remote.Types.WorkerOp +module System.Nix.Store.Remote.Types.WorkerOp ( WorkerOp(..) ) where diff --git a/hnix-store-remote/tests-io/Main.hs b/hnix-store-remote/tests-io/Main.hs index 41032de9..9ccf339b 100644 --- a/hnix-store-remote/tests-io/Main.hs +++ b/hnix-store-remote/tests-io/Main.hs @@ -1,7 +1,7 @@ module Main where -import qualified Test.Hspec -import qualified NixDaemonSpec +import Test.Hspec qualified +import NixDaemonSpec qualified -- we run remote tests in -- Linux namespaces to avoid interacting with systems store diff --git a/hnix-store-remote/tests-io/NixDaemonSpec.hs b/hnix-store-remote/tests-io/NixDaemonSpec.hs index ef327412..1f61179e 100644 --- a/hnix-store-remote/tests-io/NixDaemonSpec.hs +++ b/hnix-store-remote/tests-io/NixDaemonSpec.hs @@ -28,26 +28,26 @@ import System.Nix.StorePath.Metadata (Metadata(..)) import System.Nix.Store.Remote import System.Nix.Store.Remote.Server (WorkerHelper) import System.Process (CreateProcess(..), ProcessHandle) -import qualified Control.Concurrent -import qualified Control.Exception -import qualified Data.ByteString.Char8 -import qualified Data.Either -import qualified Data.HashSet -import qualified Data.Map -import qualified Data.Set -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified DataSink -import qualified SampleNar -import qualified System.Directory -import qualified System.Environment -import qualified System.IO.Temp -import qualified System.Linux.Namespaces -import qualified System.Nix.StorePath -import qualified System.Nix.Nar -import qualified System.Posix.User -import qualified System.Process -import qualified Test.Hspec +import Control.Concurrent qualified +import Control.Exception qualified +import Data.ByteString.Char8 qualified +import Data.Either qualified +import Data.HashSet qualified +import Data.Map qualified +import Data.Set qualified +import Data.Text qualified +import Data.Text.Encoding qualified +import DataSink qualified +import SampleNar qualified +import System.Directory qualified +import System.Environment qualified +import System.IO.Temp qualified +import System.Linux.Namespaces qualified +import System.Nix.StorePath qualified +import System.Nix.Nar qualified +import System.Posix.User qualified +import System.Process qualified +import Test.Hspec qualified createProcessEnv :: FilePath diff --git a/hnix-store-remote/tests-io/SampleNar.hs b/hnix-store-remote/tests-io/SampleNar.hs index c6ea2915..0abf9854 100644 --- a/hnix-store-remote/tests-io/SampleNar.hs +++ b/hnix-store-remote/tests-io/SampleNar.hs @@ -25,8 +25,8 @@ import Data.Default.Class import Data.STRef import Data.Word -import qualified Data.ByteString -import qualified System.Nix.Nar +import Data.ByteString qualified +import System.Nix.Nar qualified -- | Sample data for an AddToStoreNar operation data SampleNar diff --git a/hnix-store-remote/tests/Data/SerializerSpec.hs b/hnix-store-remote/tests/Data/SerializerSpec.hs index a5188600..108642a8 100644 --- a/hnix-store-remote/tests/Data/SerializerSpec.hs +++ b/hnix-store-remote/tests/Data/SerializerSpec.hs @@ -1,5 +1,6 @@ module Data.SerializerSpec (spec) where +import Control.Monad.Trans.Identity import Data.Some import Data.Serializer import Data.Serializer.Example @@ -10,34 +11,26 @@ import Test.Hspec.QuickCheck (prop) spec :: Spec spec = describe "Serializer" $ do prop "Roundtrips GADT protocol" $ \someCmd -> - (runG cmdS - <$> (runP cmdS someCmd)) + (runG cmdS $ runP cmdS someCmd) `shouldBe` - ((pure $ pure someCmd) :: - Either MyPutError - (Either (GetSerializerError MyGetError) - (Some Cmd))) - - it "Handles putS error" $ - runP cmdSPutError (Some (Cmd_Bool True)) - `shouldBe` - Left MyPutError_NoLongerSupported + (pure someCmd :: + Either (GetSerializerError MyGetError) + (Some Cmd)) it "Handles getS error" $ - runG cmdSGetError (runPutSimple cmdS (Some (Cmd_Bool True))) + runG cmdSGetError (runPutS (cmdS @IdentityT) (Some (Cmd_Bool True))) `shouldBe` Left (SerializerError_Get MyGetError_Example) it "Handles getS fail" $ - runG cmdSGetFail (runPutSimple cmdS (Some (Cmd_Bool True))) + runG cmdSGetFail (runPutS (cmdS @IdentityT) (Some (Cmd_Bool True))) `shouldBe` Left (SerializerError_GetFail @MyGetError "Failed reading: no parse\nEmpty call stack\n") prop "Roundtrips elaborate example" $ \someCmd readerBool -> - (runGRest cmdSRest readerBool 0 - <$> (runPRest cmdSRest readerBool 0 someCmd)) + (runGRest (cmdSRest readerBool) readerBool 0 + $ runPRest (cmdSRest readerBool) someCmd) `shouldBe` - ((pure $ pure $ someCmd) :: - Either MyPutError - (Either (GetSerializerError MyGetError) - (Some Cmd))) + (pure someCmd :: + Either (GetSerializerError MyGetError) + (Some Cmd)) diff --git a/hnix-store-remote/tests/EnumSpec.hs b/hnix-store-remote/tests/EnumSpec.hs index d77eaf5a..167ff27f 100644 --- a/hnix-store-remote/tests/EnumSpec.hs +++ b/hnix-store-remote/tests/EnumSpec.hs @@ -7,7 +7,7 @@ import Test.Hspec (SpecWith, Spec, describe, it, shouldBe) import Data.ByteString (ByteString) import Data.Word (Word64) import System.Nix.Build (BuildMode(..), BuildStatus(..)) -import System.Nix.Store.Remote.Serializer +import System.Nix.Store.Remote.Serializer ( activity , activityResult , enum @@ -16,7 +16,6 @@ import System.Nix.Store.Remote.Serializer , runP , LoggerSError , NixSerializer - , SError ) import System.Nix.Store.Remote.Types @@ -34,22 +33,22 @@ spec = do -> SpecWith () itE name constr value = it name - $ ((runP enum () constr) :: Either SError ByteString) + $ ((runP enum constr) :: ByteString) `shouldBe` - (runP (int @Word64) () value) + (runP (int @Word64) value) itE' :: Show a - => NixSerializer () LoggerSError a + => NixSerializer LoggerSError a -> String -> a -> Word64 -> SpecWith () itE' s name constr value = it name - $ ((runP s () constr) :: Either LoggerSError ByteString) + $ ((runP s constr) :: ByteString) `shouldBe` - (runP (int @Word64) () (value)) + (runP (int @Word64) (value)) describe "Enums" $ do describe "BuildMode enum order matches Nix" $ do diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index e229fff6..efda9a16 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -4,15 +4,13 @@ module NixSerializerSpec (spec) where import Crypto.Hash (MD5, SHA1, SHA256, SHA512) import Data.Some (Some(Some)) -import Data.Time (UTCTime) import Test.Hspec (Expectation, Spec, describe, parallel, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, arbitrary, forAll, suchThat) import System.Nix.Arbitrary () -import System.Nix.Derivation (Derivation(inputDrvs)) import System.Nix.Build (BuildResult(..)) -import System.Nix.StorePath (StoreDir) +import System.Nix.Derivation.Traditional qualified import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.Logger (Logger(..)) @@ -21,45 +19,46 @@ import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..)) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) -- | Test for roundtrip using @NixSerializer@ -roundtripSReader - :: forall r e a +roundtripS + :: forall e a . ( Eq a , Show a , Eq e , Show e ) - => NixSerializer r e a - -> r + => NixSerializer e a -> a -> Expectation -roundtripSReader serializer readerVal a = - (runG serializer readerVal - <$> runP serializer readerVal a) - `shouldBe` (pure $ pure a) +roundtripS serializer a = + (runG serializer + $ runP serializer a) + `shouldBe` (pure a) -roundtripS - :: ( Eq a +roundtripSReader + :: forall r e a + . ( Eq a , Show a , Eq e , Show e ) - => NixSerializer () e a + => (r -> NixSerializer e a) + -> r -> a -> Expectation -roundtripS serializer = roundtripSReader serializer () +roundtripSReader serializer r = roundtripS $ serializer r spec :: Spec spec = parallel $ do describe "Prim" $ do - prop "Int" $ roundtripS @Int @() int + prop "Int" $ roundtripS @() $ int @Int prop "Bool" $ roundtripS bool prop "ByteString" $ roundtripS byteString prop "Text" $ roundtripS text prop "Maybe Text" $ roundtripS maybeText - prop "UTCTime" $ roundtripS @UTCTime @() time + prop "UTCTime" $ roundtripS @() time describe "Combinators" $ do - prop "list" $ roundtripS @[Int] @() (list int) + prop "list" $ roundtripS @() (list $ int @Int) prop "set" $ roundtripS (set byteString) prop "hashSet" $ roundtripS (hashSet byteString) prop "mapS" $ roundtripS (mapS (int @Int) byteString) @@ -71,7 +70,7 @@ spec = parallel $ do prop "< 1.28" $ \sd -> forAll (arbitrary `suchThat` ((< 28) . protoVersion_minor)) $ \pv -> - roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv) + roundtripS (buildResult sd pv) . (\x -> x { buildResultBuiltOutputs = Nothing }) . (\x -> x { buildResultTimesBuilt = Nothing , buildResultIsNonDeterministic = Nothing @@ -81,7 +80,7 @@ spec = parallel $ do ) prop "= 1.28" $ \sd -> - roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd (ProtoVersion 1 28)) + roundtripS (buildResult sd $ ProtoVersion 1 28) . (\x -> x { buildResultTimesBuilt = Nothing , buildResultIsNonDeterministic = Nothing , buildResultStartTime = Nothing @@ -91,10 +90,10 @@ spec = parallel $ do prop "> 1.28" $ \sd -> forAll (arbitrary `suchThat` ((> 28) . protoVersion_minor)) $ \pv -> - roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv) + roundtripS $ buildResult sd pv prop "StorePath" $ - roundtripSReader @StoreDir storePath + roundtripSReader storePath prop "StorePathHashPart" $ roundtripS storePathHashPart @@ -103,7 +102,7 @@ spec = parallel $ do roundtripS storePathName prop "Metadata (StorePath)" $ - roundtripSReader @StoreDir pathMetadata + roundtripSReader pathMetadata prop "Some HashAlgo" $ roundtripS someHashAlgo @@ -114,11 +113,11 @@ spec = parallel $ do prop "SHA256" $ roundtripS . digest @SHA256 prop "SHA512" $ roundtripS . digest @SHA512 - prop "Derivation" $ \sd -> - roundtripSReader @StoreDir derivation sd - . (\drv -> drv { inputDrvs = mempty }) + prop "Derivation" $ \sd drv -> + roundtripS (basicDerivation sd) $ + System.Nix.Derivation.Traditional.withoutName drv - prop "ProtoVersion" $ roundtripS @ProtoVersion @() protoVersion + prop "ProtoVersion" $ roundtripS @() protoVersion describe "Logger" $ do prop "ActivityID" $ roundtripS activityID @@ -134,7 +133,7 @@ spec = parallel $ do $ forAll (arbitrary :: Gen ProtoVersion) $ \pv -> forAll (arbitrary `suchThat` errorInfoIf (protoVersion_minor pv >= 26)) - $ roundtripSReader logger pv + $ roundtripS $ logger pv describe "Handshake" $ do prop "WorkerMagic" $ roundtripS workerMagic @@ -147,18 +146,19 @@ spec = parallel $ do prop "StoreRequest" $ \testStoreConfig -> forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig))) - $ roundtripSReader @ProtoStoreConfig storeRequest testStoreConfig + $ roundtripS $ storeRequest + (protoStoreConfigDir testStoreConfig) + (protoStoreConfigProtoVersion testStoreConfig) describe "StoreReply" $ do prop "()" $ roundtripS opSuccess - prop "GCResult" $ roundtripSReader @StoreDir gcResult + prop "GCResult" $ roundtripSReader gcResult prop "GCRoot" $ roundtripS gcRoot - prop "Missing" $ roundtripSReader @StoreDir missing - prop "Maybe (Metadata StorePath)" $ roundtripSReader @StoreDir maybePathMetadata + prop "Missing" $ roundtripSReader missing + prop "Maybe (Metadata StorePath)" $ roundtripSReader maybePathMetadata restrictProtoVersion :: ProtoVersion -> Some StoreRequest -> Bool restrictProtoVersion v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False -restrictProtoVersion _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty restrictProtoVersion v (Some (QueryMissing _)) | v < ProtoVersion 1 30 = False restrictProtoVersion _ _ = True diff --git a/hnix-store-tests/hnix-store-tests.cabal b/hnix-store-tests/hnix-store-tests.cabal index 837da6b4..3f9c99da 100644 --- a/hnix-store-tests/hnix-store-tests.cabal +++ b/hnix-store-tests/hnix-store-tests.cabal @@ -28,6 +28,7 @@ common commons , FlexibleInstances , ScopedTypeVariables , StandaloneDeriving + , ImportQualifiedPost , RecordWildCards , TypeApplications , LambdaCase @@ -61,13 +62,16 @@ library , hnix-store-core >= 0.8 , bytestring , containers + , constraints-extras , crypton , dependent-sum > 0.7 , generic-arbitrary < 1.1 , hashable , hspec + , monoidal-containers , QuickCheck , text + , these , time , unordered-containers , vector @@ -94,5 +98,8 @@ test-suite props , hnix-store-core , hnix-store-tests , attoparsec + , dependent-sum + , containers , text , hspec + , QuickCheck diff --git a/hnix-store-tests/src/Data/ByteString/Arbitrary.hs b/hnix-store-tests/src/Data/ByteString/Arbitrary.hs index 00248002..b0287787 100644 --- a/hnix-store-tests/src/Data/ByteString/Arbitrary.hs +++ b/hnix-store-tests/src/Data/ByteString/Arbitrary.hs @@ -3,7 +3,7 @@ module Data.ByteString.Arbitrary () where import Data.ByteString (ByteString) import Test.QuickCheck (Arbitrary(..)) -import qualified Data.ByteString.Char8 +import Data.ByteString.Char8 qualified instance Arbitrary ByteString where arbitrary = Data.ByteString.Char8.pack <$> arbitrary diff --git a/hnix-store-tests/src/Data/HashSet/Arbitrary.hs b/hnix-store-tests/src/Data/HashSet/Arbitrary.hs index a992a5a4..fb4dd2d6 100644 --- a/hnix-store-tests/src/Data/HashSet/Arbitrary.hs +++ b/hnix-store-tests/src/Data/HashSet/Arbitrary.hs @@ -4,7 +4,7 @@ module Data.HashSet.Arbitrary where import Data.Hashable (Hashable) import Data.HashSet (HashSet) import Test.QuickCheck (Arbitrary(..)) -import qualified Data.HashSet +import Data.HashSet qualified instance (Hashable a, Eq a, Arbitrary a) => Arbitrary (HashSet a) where arbitrary = Data.HashSet.fromList <$> arbitrary diff --git a/hnix-store-tests/src/Data/Text/Arbitrary.hs b/hnix-store-tests/src/Data/Text/Arbitrary.hs index 34cba8e9..7cdf1357 100644 --- a/hnix-store-tests/src/Data/Text/Arbitrary.hs +++ b/hnix-store-tests/src/Data/Text/Arbitrary.hs @@ -3,7 +3,7 @@ module Data.Text.Arbitrary () where import Data.Text (Text) import Test.QuickCheck (Arbitrary(..), frequency, suchThat) -import qualified Data.Text +import Data.Text qualified instance Arbitrary Text where arbitrary = Data.Text.pack <$> arbitrary diff --git a/hnix-store-tests/src/Data/Vector/Arbitrary.hs b/hnix-store-tests/src/Data/Vector/Arbitrary.hs index 0d006dc7..abde12fd 100644 --- a/hnix-store-tests/src/Data/Vector/Arbitrary.hs +++ b/hnix-store-tests/src/Data/Vector/Arbitrary.hs @@ -4,7 +4,7 @@ module Data.Vector.Arbitrary () where import Data.Vector (Vector) import Test.QuickCheck (Arbitrary(..), Arbitrary1(..), arbitrary1, shrink1) -import qualified Data.Vector +import Data.Vector qualified instance Arbitrary1 Vector where liftArbitrary = diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs index 3cd24296..3d7a0f7d 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs @@ -13,7 +13,7 @@ import System.Nix.Arbitrary.UTCTime () import System.Nix.Build -import qualified Data.Time.Clock.POSIX +import Data.Time.Clock.POSIX qualified deriving via GenericArbitrary BuildMode instance Arbitrary BuildMode diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs index 9910dee9..2d08ca15 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs @@ -1,19 +1,130 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} -- due to recent generic-arbitrary {-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} {-# OPTIONS_GHC -Wno-orphans #-} module System.Nix.Arbitrary.Derivation where -import Data.Text (Text) +import Data.Constraint.Extras +import Data.Dependent.Sum +import Data.Either (isRight) +import Data.Map (Map) +import Data.Map qualified +import Data.Map.Monoidal +import Data.Some import Data.Text.Arbitrary () +import Data.These import Data.Vector.Arbitrary () -import System.Nix.Derivation -import System.Nix.StorePath (StorePath) +import Test.QuickCheck.Arbitrary.Generic +import Test.QuickCheck.Gen -import Test.QuickCheck (Arbitrary(..)) -import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) +import System.Nix.StorePath +import System.Nix.ContentAddress +import System.Nix.Hash +import System.Nix.Derivation +import System.Nix.OutputName +import System.Nix.Arbitrary.ContentAddress () +import System.Nix.Arbitrary.Hash (genDSum) import System.Nix.Arbitrary.StorePath () +import System.Nix.Arbitrary.OutputName () + +-- | ensure output path name is not too long +shortEnoughOutputName :: StorePathName -> Gen (OutputName) +shortEnoughOutputName drvName = + arbitrary `suchThat` \outputName -> isRight $ outputStoreObjectName drvName outputName + +-- | Also ensures at least one output +shortEnoughOutputsName :: Arbitrary a => StorePathName -> Gen (Map OutputName a) +shortEnoughOutputsName drvName = fmap Data.Map.fromList $ listOf1 $ (,) <$> shortEnoughOutputName drvName <*> arbitrary + +shortEnoughOutputs :: StorePathName -> Gen DerivationOutputs +shortEnoughOutputs drvName = + genDSum arbitrary $ \tag -> has @Arbitrary tag $ shortEnoughOutputsName drvName + +-- | Ensure a valid combination +ensureValidMethodAlgo :: ContentAddressMethod -> HashAlgo a -> Bool +ensureValidMethodAlgo = \case + ContentAddressMethod_Text -> \case + HashAlgo_SHA256 -> True + _ -> False + _ -> \_ -> True + +instance + ( Arbitrary inputs + , Arbitrary output + , Arg (Derivation' inputs (Map OutputName output)) inputs + , Arg (Derivation' inputs (Map OutputName output)) output + ) => Arbitrary (Derivation' inputs (Map OutputName output)) + where + arbitrary = do + drv <- genericArbitrary + om <- shortEnoughOutputsName $ name drv + let + drv' = drv { outputs = om } + -- type inference hint + _ = [drv, drv'] + pure drv' + shrink = genericShrink + +instance + ( Arbitrary inputs + , Arg (Derivation' inputs DerivationOutputs) inputs + ) => Arbitrary (Derivation' inputs DerivationOutputs) + where + arbitrary = do + drv <- genericArbitrary + os <- shortEnoughOutputs $ name drv + let + drv' = drv { outputs = os } + -- type inference hint + _ = [drv, drv'] + pure drv' + shrink = genericShrink + +deriving via GenericArbitrary FreeformDerivationOutput + instance Arbitrary FreeformDerivationOutput + +deriving via GenericArbitrary InputAddressedDerivationOutput + instance Arbitrary InputAddressedDerivationOutput + +instance Arbitrary FixedDerivationOutput where + arbitrary = genericArbitrary `suchThat` + \(FixedDerivationOutput {fMethod, fHash = hashAlgo :=> _}) -> + ensureValidMethodAlgo fMethod hashAlgo + +instance Arbitrary ContentAddressedDerivationOutput where + arbitrary = genericArbitrary `suchThat` + \(ContentAddressedDerivationOutput {caMethod, caHashAlgo = Some hashAlgo }) -> + ensureValidMethodAlgo caMethod hashAlgo + +instance Arbitrary (Some DerivationType) where + arbitrary = + oneof + $ pure + <$> [ + Some DerivationType_InputAddressing + , Some DerivationType_Fixed + , Some DerivationType_ContentAddressing + ] + +deriving via GenericArbitrary DerivationInputs + instance Arbitrary DerivationInputs + +deriving via GenericArbitrary DerivedPathMap + instance Arbitrary DerivedPathMap + +deriving via GenericArbitrary ChildNode + instance Arbitrary ChildNode + +-- TODO these belong elsewhere + +deriving newtype instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (MonoidalMap k v) -deriving via GenericArbitrary (Derivation StorePath Text) - instance Arbitrary (Derivation StorePath Text) -deriving via GenericArbitrary (DerivationOutput StorePath Text) - instance Arbitrary (DerivationOutput StorePath Text) +deriving via GenericArbitrary (These a b) + instance ( Arg (These a b) a + , Arg (These a b) b + , Arbitrary a + , Arbitrary b + ) => Arbitrary (These a b) diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs b/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs index 1a3c56dc..19b1717f 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs @@ -3,12 +3,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} module System.Nix.Arbitrary.DerivedPath where -import qualified Data.Set +import Data.Set qualified import Test.QuickCheck (Arbitrary(..), oneof) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) import System.Nix.Arbitrary.OutputName () import System.Nix.Arbitrary.StorePath () -import System.Nix.DerivedPath (DerivedPath, OutputsSpec(..)) +import System.Nix.DerivedPath (SingleDerivedPath, DerivedPath, OutputsSpec(..)) instance Arbitrary OutputsSpec where arbitrary = oneof @@ -18,5 +18,8 @@ instance Arbitrary OutputsSpec where <$> ((:) <$> arbitrary <*> arbitrary) ] +deriving via GenericArbitrary SingleDerivedPath + instance Arbitrary SingleDerivedPath + deriving via GenericArbitrary DerivedPath instance Arbitrary DerivedPath diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs index ad9b3086..639a94c6 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + -- due to recent generic-arbitrary {-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -5,14 +10,17 @@ module System.Nix.Arbitrary.Hash where import Data.ByteString (ByteString) import Data.ByteString.Arbitrary () +import Data.Constraint.Extras import Crypto.Hash (Digest, MD5(..), SHA1(..), SHA256(..), SHA512(..)) import Data.Dependent.Sum (DSum((:=>))) import Data.Some (Some(Some)) +import GHC.Generics + import System.Nix.Hash (HashAlgo(..)) -import Test.QuickCheck (Arbitrary(arbitrary), oneof) +import Test.QuickCheck (Arbitrary(arbitrary), Gen, oneof) -import qualified Crypto.Hash +import Crypto.Hash qualified -- * Arbitrary @Digest@s @@ -28,15 +36,7 @@ instance Arbitrary (Digest SHA256) where instance Arbitrary (Digest SHA512) where arbitrary = Crypto.Hash.hash @ByteString <$> arbitrary --- * Arbitrary @DSum HashAlgo Digest@s - -instance Arbitrary (DSum HashAlgo Digest) where - arbitrary = oneof - [ (HashAlgo_MD5 :=>) <$> arbitrary - , (HashAlgo_SHA1 :=>) <$> arbitrary - , (HashAlgo_SHA256 :=>) <$> arbitrary - , (HashAlgo_SHA512 :=>) <$> arbitrary - ] +-- * Arbitrary @Some HashAlgo@ instance Arbitrary (Some HashAlgo) where arbitrary = @@ -48,3 +48,15 @@ instance Arbitrary (Some HashAlgo) where , Some HashAlgo_SHA256 , Some HashAlgo_SHA512 ] + +-- * TODO Upstream + +genDSum :: Gen (Some f) -> (forall a. f a -> Gen (g a)) -> Gen (DSum f g) +genDSum genTag genValue = genTag >>= \(Some tag) -> + (tag :=>) <$> genValue tag + +instance (Arbitrary (Some f), Has' Arbitrary f g) => Arbitrary (DSum f g) where + arbitrary = genDSum arbitrary (\tag -> has' @Arbitrary @g tag arbitrary) + +instance (Arbitrary (f (g a))) => Arbitrary ((f :.: g) a) where + arbitrary = Comp1 <$> arbitrary diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs b/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs index 0ef7ba21..f749ea9d 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs @@ -3,20 +3,15 @@ module System.Nix.Arbitrary.OutputName where import System.Nix.OutputName (OutputName) -import qualified Data.Text -import qualified System.Nix.OutputName +import System.Nix.OutputName qualified +import System.Nix.StorePath qualified -import Test.QuickCheck (Arbitrary(arbitrary), choose, elements, vectorOf) +import Test.QuickCheck (Arbitrary(arbitrary)) +import System.Nix.Arbitrary.StorePath () instance Arbitrary OutputName where arbitrary = - either (error . show) id + either (error . show) id . System.Nix.OutputName.mkOutputName - . Data.Text.pack <$> ((:) <$> s1 <*> limited sn) - where - alphanum = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] - s1 = elements $ alphanum <> "+-_?=" - sn = elements $ alphanum <> "+-._?=" - limited n = do - k <- choose (0, 210) - vectorOf k n + . System.Nix.StorePath.unStorePathName + <$> arbitrary diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs index 509b26af..5fa26e51 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs @@ -9,16 +9,16 @@ import System.Nix.Arbitrary.Hash () import System.Nix.Arbitrary.OutputName () import System.Nix.Arbitrary.Signature () import System.Nix.Arbitrary.StorePath () -import System.Nix.Realisation (DerivationOutput, Realisation) +import System.Nix.Realisation (BuildTraceKey, Realisation) import Test.QuickCheck (Arbitrary(..)) import Test.QuickCheck.Arbitrary.Generic (Arg, GenericArbitrary(..), genericArbitrary, genericShrink) instance - ( Arg (DerivationOutput outputName) outputName + ( Arg (BuildTraceKey outputName) outputName , Arbitrary outputName ) => - Arbitrary (DerivationOutput outputName) + Arbitrary (BuildTraceKey outputName) where arbitrary = genericArbitrary shrink = genericShrink diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs index b11f9ae7..95792e18 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs @@ -4,10 +4,10 @@ {-# LANGUAGE OverloadedStrings #-} module System.Nix.Arbitrary.Signature where -import qualified Crypto.PubKey.Ed25519 +import Crypto.PubKey.Ed25519 qualified import Crypto.Random (drgNewTest, withDRG) -import qualified Data.ByteString as BS -import qualified Data.Text as Text +import Data.ByteString qualified as BS +import Data.Text qualified as Text import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) import Test.QuickCheck diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs index c07c9b39..7e1db845 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs @@ -6,14 +6,14 @@ module System.Nix.Arbitrary.StorePath where import Control.Applicative (liftA2) #endif import Crypto.Hash (MD5, SHA1, SHA256, SHA512) -import qualified Data.ByteString.Char8 -import qualified Data.Text +import Data.ByteString.Char8 qualified +import Data.Text qualified import System.Nix.StorePath (StoreDir(..) , StorePath , StorePathName , StorePathHashPart ) -import qualified System.Nix.StorePath +import System.Nix.StorePath qualified import Test.QuickCheck (Arbitrary(arbitrary), choose, elements, oneof, vectorOf) diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs index 8cd26b67..23625846 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs @@ -14,7 +14,7 @@ import System.Nix.Arbitrary.UTCTime () import System.Nix.StorePath (StorePath) import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust) -import qualified System.Nix.Hash +import System.Nix.Hash qualified import Test.QuickCheck (Arbitrary(..), suchThat) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) diff --git a/hnix-store-tests/tests/ContentAddressSpec.hs b/hnix-store-tests/tests/ContentAddressSpec.hs index 7acbd6c7..398fe801 100644 --- a/hnix-store-tests/tests/ContentAddressSpec.hs +++ b/hnix-store-tests/tests/ContentAddressSpec.hs @@ -5,7 +5,7 @@ import Test.Hspec.QuickCheck (prop) import Test.Hspec.Nix (roundtrips) import System.Nix.Arbitrary () -import qualified System.Nix.ContentAddress +import System.Nix.ContentAddress qualified spec :: Spec spec = do diff --git a/hnix-store-tests/tests/DerivationSpec.hs b/hnix-store-tests/tests/DerivationSpec.hs index 650de752..c317a470 100644 --- a/hnix-store-tests/tests/DerivationSpec.hs +++ b/hnix-store-tests/tests/DerivationSpec.hs @@ -1,27 +1,45 @@ module DerivationSpec where +import Data.Functor.Identity (Identity(..)) import Test.Hspec (Spec, describe) -import Test.Hspec.QuickCheck (xprop) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck import Test.Hspec.Nix (roundtrips) import System.Nix.Arbitrary () -import System.Nix.Derivation (parseDerivation, buildDerivation) +import System.Nix.Arbitrary.Derivation +import System.Nix.Derivation -import qualified Data.Attoparsec.Text -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder - --- TODO(srk): this won't roundtrip as Arbitrary Text --- contains wild stuff like control characters and UTF8 sequences. --- Either fix in nix-derivation or use wrapper type --- (but we use Nix.Derivation.textParser so we need Text for now) spec :: Spec spec = do - describe "Derivation" $ do - xprop "roundtrips via Text" $ \sd -> + describe "DerivationInput" $ do + prop "roundtrips to (Set SingleDerivedPath)" $ + -- Order is important, 'Set SingleDerivedPath' is the normal from, + -- since the arbitrary instance for 'DerivationInput' doesn't + -- properly avoid empty child maps. + roundtrips + (foldMap derivationInputsFromSingleDerivedPath) + (Identity . derivationInputsToDerivedPaths) + + describe "DerivationOutput" $ do + prop "roundtrips to FreeformDerivationOutput" $ \storeDir storePathName output -> do + outputName <- generate $ shortEnoughOutputName storePathName roundtrips - ( Data.Text.Lazy.toStrict - . Data.Text.Lazy.Builder.toLazyText - . buildDerivation sd - ) - (Data.Attoparsec.Text.parseOnly (parseDerivation sd)) + (fromSpecificOutput storeDir storePathName outputName) + (toSpecificOutput @Maybe storeDir storePathName outputName) + output + + -- Sometimes infinite loops, not sure why + + -- describe "DerivationOutputs" $ do + -- prop "roundtrips to FreeformDerivationOutputs" $ verboseCheck $ \storeDir storePathName -> do + -- outputs <- generate $ shortEnoughOutputs storePathName + -- _ <- roundtrips + -- (fromSpecificOutputs storeDir storePathName) + -- (toSpecificOutputs @Maybe storeDir storePathName) + -- outputs + -- pure () + +-- -- | Useful for debugging +-- instance MonadFail (Either String) where +-- fail = Left diff --git a/hnix-store-tests/tests/DerivedPathSpec.hs b/hnix-store-tests/tests/DerivedPathSpec.hs index 7debac2e..d9423f67 100644 --- a/hnix-store-tests/tests/DerivedPathSpec.hs +++ b/hnix-store-tests/tests/DerivedPathSpec.hs @@ -6,10 +6,16 @@ import Test.Hspec.Nix (roundtrips) import System.Nix.Arbitrary () -import qualified System.Nix.DerivedPath +import System.Nix.DerivedPath qualified spec :: Spec spec = do + describe "SingleDerivedPath" $ do + prop "roundtrips" $ \sd -> + roundtrips + (System.Nix.DerivedPath.singleDerivedPathToText sd) + (System.Nix.DerivedPath.parseSingleDerivedPath sd) + describe "DerivedPath" $ do prop "roundtrips" $ \sd -> roundtrips diff --git a/hnix-store-tests/tests/RealisationSpec.hs b/hnix-store-tests/tests/RealisationSpec.hs index 022b5402..1f0c9f65 100644 --- a/hnix-store-tests/tests/RealisationSpec.hs +++ b/hnix-store-tests/tests/RealisationSpec.hs @@ -6,21 +6,22 @@ import Test.Hspec.Nix (roundtrips) import System.Nix.Arbitrary () -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder -import qualified System.Nix.OutputName -import qualified System.Nix.Realisation +import Data.Text.Lazy qualified +import Data.Text.Lazy.Builder qualified +import System.Nix.StorePath qualified +import System.Nix.OutputName qualified +import System.Nix.Realisation qualified spec :: Spec spec = do - describe "DerivationOutput" $ do + describe "BuildTraceKey" $ do prop "roundtrips" $ roundtrips ( Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText - . System.Nix.Realisation.derivationOutputBuilder - System.Nix.OutputName.unOutputName + . System.Nix.Realisation.buildTraceKeyBuilder + (System.Nix.StorePath.unStorePathName . System.Nix.OutputName.unOutputName) ) - ( System.Nix.Realisation.derivationOutputParser + ( System.Nix.Realisation.buildTraceKeyParser System.Nix.OutputName.mkOutputName ) diff --git a/hnix-store-tests/tests/StorePathSpec.hs b/hnix-store-tests/tests/StorePathSpec.hs index 7c83f354..2e791afd 100644 --- a/hnix-store-tests/tests/StorePathSpec.hs +++ b/hnix-store-tests/tests/StorePathSpec.hs @@ -7,7 +7,7 @@ import Test.Hspec.Nix (roundtrips) import System.Nix.Arbitrary () import System.Nix.StorePath -import qualified Data.Attoparsec.Text +import Data.Attoparsec.Text qualified spec :: Spec spec = do diff --git a/overlay.nix b/overlay.nix index e19b142d..1940751e 100644 --- a/overlay.nix +++ b/overlay.nix @@ -33,6 +33,12 @@ in [ haskellLib.compose.buildFromSdist ]; + hnix-store-aterm = + lib.pipe + (hself.callCabal2nix "hnix-store-aterm" ./hnix-store-aterm {}) + [ + haskellLib.compose.buildFromSdist + ]; hnix-store-json = lib.pipe (hself.callCabal2nix "hnix-store-json" ./hnix-store-json {})