diff --git a/cabal.project b/cabal.project index 05e0db17..db09e180 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 1bec5bce..8a25b47c 100644 --- a/default.nix +++ b/default.nix @@ -23,6 +23,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..17ad9c56 --- /dev/null +++ b/hnix-store-aterm/README.md @@ -0,0 +1,217 @@ +# `hnix-store-aterm` + +[![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..53266b72 --- /dev/null +++ b/hnix-store-aterm/hnix-store-aterm.cabal @@ -0,0 +1,116 @@ +Cabal-Version: 2.2 +Name: hnix-store-aterm +Version: 1.1.3 +Build-Type: Simple +Tested-With: GHC == 9.8.4, GHC == 9.6.6, GHC == 9.4.8 +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/haskell-nix/hnix-store + +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 , + generic-arbitrary < 1.1 , + QuickCheck < 2.16, + text , + +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 99% rename from hnix-store-core/tests/Derivation.hs rename to hnix-store-aterm/tests/Derivation.hs index 0737f494..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) 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 425a68d6..c037441c 100644 --- a/hnix-store-core/hnix-store-core.cabal +++ b/hnix-store-core/hnix-store-core.cabal @@ -90,12 +90,14 @@ library , 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 , text , time , unordered-containers @@ -107,7 +109,6 @@ test-suite core type: exitcode-stdio-1.0 main-is: Driver.hs other-modules: - Derivation Fingerprint Hash Placeholder @@ -119,7 +120,6 @@ test-suite core tasty-discover:tasty-discover build-depends: hnix-store-core - , attoparsec , base , base16-bytestring , base64-bytestring @@ -129,7 +129,6 @@ test-suite core , data-default-class , hspec , tasty - , tasty-golden , tasty-hspec , text , time diff --git a/hnix-store-core/src/System/Nix/Derivation.hs b/hnix-store-core/src/System/Nix/Derivation.hs index ff87f5d2..56e61536 100644 --- a/hnix-store-core/src/System/Nix/Derivation.hs +++ b/hnix-store-core/src/System/Nix/Derivation.hs @@ -1,45 +1,366 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +-- See TODOs bellow +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | 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 Data.Attoparsec.Text.Lazy qualified -import Data.Text qualified -import Data.Text.Lazy qualified -import Data.Text.Lazy.Builder qualified - -import Nix.Derivation qualified -import System.Nix.StorePath qualified - -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-db/hnix-store-db.cabal b/hnix-store-db/hnix-store-db.cabal index 4910c626..a0100c3a 100644 --- a/hnix-store-db/hnix-store-db.cabal +++ b/hnix-store-db/hnix-store-db.cabal @@ -32,32 +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 diff --git a/hnix-store-json/CHANGELOG.md b/hnix-store-json/CHANGELOG.md index ab076afc..fc920ca3 100644 --- a/hnix-store-json/CHANGELOG.md +++ b/hnix-store-json/CHANGELOG.md @@ -11,6 +11,7 @@ The test suite is now much more comprenesive, uses test data from upstream Nix t * `OutputsSpec` * `SingleDerivedPath` * `DerivedPath` + * `Derivation` * `BuildResult` # 0.1.0.0 2024-07-31 diff --git a/hnix-store-json/hnix-store-json.cabal b/hnix-store-json/hnix-store-json.cabal index 14a751d6..9ce68ce9 100644 --- a/hnix-store-json/hnix-store-json.cabal +++ b/hnix-store-json/hnix-store-json.cabal @@ -26,6 +26,13 @@ data-files: upstream-libstore-data/derived-path/single_built_built.json upstream-libstore-data/derived-path/single_built.json upstream-libstore-data/derived-path/single_opaque.json + upstream-libstore-data/derivation/dyn-dep-derivation.json + upstream-libstore-data/derivation/output-caFixedFlat.json + upstream-libstore-data/derivation/output-caFixedNAR.json + upstream-libstore-data/derivation/output-caFixedText.json + upstream-libstore-data/derivation/output-caFloating.json + upstream-libstore-data/derivation/output-inputAddressed.json + upstream-libstore-data/derivation/simple-derivation.json upstream-libstore-data/outputs-spec/all.json upstream-libstore-data/outputs-spec/name.json upstream-libstore-data/outputs-spec/names.json @@ -68,7 +75,9 @@ library , crypton , dependent-sum , deriving-aeson >= 0.2 + , monoidal-containers , text + , these , time hs-source-dirs: src @@ -79,6 +88,7 @@ test-suite json other-modules: BuildResultSpec ContentAddressSpec + DerivationSpec DerivedPathSpec HashSpec JSONSpec @@ -102,4 +112,10 @@ test-suite json , aeson , bytestring , containers + , crypton + , dependent-sum , hspec + , monoidal-containers + , some + , these + , vector diff --git a/hnix-store-json/src/System/Nix/JSON.hs b/hnix-store-json/src/System/Nix/JSON.hs index 0e977cbb..73de67e4 100644 --- a/hnix-store-json/src/System/Nix/JSON.hs +++ b/hnix-store-json/src/System/Nix/JSON.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MonoLocalBinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Description : JSON serialization @@ -15,6 +16,7 @@ module System.Nix.JSON import Control.Applicative ((<|>)) import Crypto.Hash (Digest) import Data.Aeson +import Data.Aeson.Key qualified import Data.Aeson.KeyMap qualified import Data.Aeson.Types (Parser) import Data.Aeson.Types qualified @@ -24,13 +26,16 @@ import Data.Constraint.Extras (Has(has)) import Data.Dependent.Sum import Data.Foldable (toList) import Data.Map.Strict qualified -import Data.Maybe (maybeToList) +import Data.Map.Monoidal qualified +import Data.Maybe (fromMaybe, maybeToList) import Data.Set qualified import Data.Some import Data.Text (Text) import Data.Text qualified import Data.Text.Lazy qualified import Data.Text.Lazy.Builder qualified +import Data.These +import Data.These.Combinators import Data.Time (diffUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Deriving.Aeson @@ -39,9 +44,10 @@ import System.Nix.Base (baseEncodingToText, textToBaseEncoding) import System.Nix.Base qualified import System.Nix.Build (BuildResult(..), BuildSuccess(..), BuildFailure(..), BuildSuccessStatus(..), BuildFailureStatus(..)) import System.Nix.ContentAddress +import System.Nix.Derivation import System.Nix.DerivedPath (DerivedPath(..), OutputsSpec(..), SingleDerivedPath(..)) import System.Nix.Hash -import System.Nix.OutputName (OutputName) +import System.Nix.OutputName (OutputName, mkOutputName) import System.Nix.OutputName qualified import System.Nix.Realisation (BuildTraceKey(..), Realisation, RealisationWithId(..)) import System.Nix.Realisation qualified @@ -93,6 +99,109 @@ instance FromJSONKey StorePath where fromJSONKey = FromJSONKeyTextParser $ either (fail . show @System.Nix.StorePath.InvalidPathError) pure . parseBasePathFromText +deriving newtype instance FromJSON DerivedPathMap +deriving newtype instance ToJSON DerivedPathMap + +instance FromJSON ChildNode where + parseJSON = withObject "ChildNode" $ \obj -> do + outputs <- obj .: "outputs" + dynamicOutputs <- obj .: "dynamicOutputs" + ChildNode <$> case (Data.Set.null outputs, Data.Map.Monoidal.null dynamicOutputs) of + (False, True) -> pure $ This outputs + (True, False) -> pure $ That dynamicOutputs + (False, False) -> pure $ These outputs dynamicOutputs + (True, True) -> fail "outputs and dynamic outputs cannot both be empty" + +instance ToJSON ChildNode where + toJSON (ChildNode cn) = object + [ "outputs" .= fromMaybe Data.Set.empty (justHere cn) + , "dynamicOutputs" .= fromMaybe Data.Map.Monoidal.empty (justThere cn) + ] + +-- | Input-addressed derivation output JSON instance +instance FromJSON InputAddressedDerivationOutput where + parseJSON = withObject "InputAddressedDerivationOutput" $ \obj -> + InputAddressedDerivationOutput <$> obj .: "path" + +instance ToJSON InputAddressedDerivationOutput where + toJSON (InputAddressedDerivationOutput path) = + object ["path" .= path] + +-- | Fixed derivation output JSON instance +instance FromJSON FixedDerivationOutput where + parseJSON = withObject "FixedDerivationOutput" $ \obj -> do + method <- obj .: "method" >>= either fail pure . textToMethod + HashJSON hash <- obj .: "hash" + pure $ FixedDerivationOutput method hash + +instance ToJSON FixedDerivationOutput where + toJSON (FixedDerivationOutput method hash) = + object + [ "method" .= methodToText method + , "hash" .= HashJSON hash + ] + +-- | Content-addressed derivation output JSON instance +instance FromJSON ContentAddressedDerivationOutput where + parseJSON = withObject "ContentAddressedDerivationOutput" $ \obj -> do + method <- obj .: "method" >>= either fail pure . textToMethod + hashAlgo <- obj .: "hashAlgo" >>= either fail pure . textToAlgo + pure $ ContentAddressedDerivationOutput method hashAlgo + +instance ToJSON ContentAddressedDerivationOutput where + toJSON (ContentAddressedDerivationOutput method (Some hashAlgo)) = + object + [ "method" .= methodToText method + , "hashAlgo" .= algoToText hashAlgo + ] + +-- Helper to parse DerivationOutputs from JSON +parseDerivationOutputs :: Object -> Parser DerivationOutputs +parseDerivationOutputs obj = do + let outputPairs = Data.Aeson.KeyMap.toList obj + case outputPairs of + [] -> pure $ DerivationType_InputAddressing :=> mempty + (_, firstVal) : _ -> do + -- Parse the first output to determine the derivation type + withObject "first output" (\first -> do + -- Determine type by checking which fields are present + let hasPath = Data.Aeson.KeyMap.member "path" first + hasMethod = Data.Aeson.KeyMap.member "method" first + hasHash = Data.Aeson.KeyMap.member "hash" first + hasHashAlgo = Data.Aeson.KeyMap.member "hashAlgo" first + + case (hasPath, hasMethod, hasHash, hasHashAlgo) of + (True, False, False, False) -> do + -- Input-addressed + outputs <- Data.Map.Strict.fromList <$> mapM (\(k, v) -> do + outputName <- either (fail . show) pure $ mkOutputName $ Data.Aeson.Key.toText k + output <- parseJSON v + pure (outputName, output)) outputPairs + pure $ DerivationType_InputAddressing :=> outputs + (False, True, True, False) -> do + -- Fixed + outputs <- Data.Map.Strict.fromList <$> mapM (\(k, v) -> do + outputName <- either (fail . show) pure $ mkOutputName $ Data.Aeson.Key.toText k + output <- parseJSON v + pure (outputName, output)) outputPairs + pure $ DerivationType_Fixed :=> outputs + (False, True, False, True) -> do + -- Content-addressed + outputs <- Data.Map.Strict.fromList <$> mapM (\(k, v) -> do + outputName <- either (fail . show) pure $ mkOutputName $ Data.Aeson.Key.toText k + output <- parseJSON v + pure (outputName, output)) outputPairs + pure $ DerivationType_ContentAddressing :=> outputs + _ -> fail $ "Invalid output format: " <> show (hasPath, hasMethod, hasHash, hasHashAlgo) + ) firstVal + +-- Helper to serialize DerivationOutputs to JSON +derivationOutputsToJSON :: DerivationOutputs -> Value +derivationOutputsToJSON (ty :=> outputs) = case ty of + DerivationType_InputAddressing -> toJSON outputs + DerivationType_Fixed -> toJSON outputs + DerivationType_ContentAddressing -> toJSON outputs + instance FromJSONKey StorePathName where fromJSONKey = FromJSONKeyTextParser $ either (fail . show) pure . mkStorePathName @@ -104,6 +213,37 @@ deriving newtype instance ToJSON OutputName deriving newtype instance FromJSONKey OutputName deriving newtype instance ToJSONKey OutputName +-- | TODO: hacky, we need to stop assuming StoreDir for +-- StorePath to and from JSON +instance FromJSON Derivation where + parseJSON = withObject "Derivation" $ \v -> do + name <- v .: "name" + inputs <- v .: "inputs" >>= \inputsObj -> DerivationInputs + <$> inputsObj .: "srcs" + <*> inputsObj .: "drvs" + outputs <- v .: "outputs" >>= parseDerivationOutputs + Derivation name outputs + <$> pure inputs + <*> v .: "system" + <*> v .: "builder" + <*> v .: "args" + <*> v .: "env" + +instance ToJSON Derivation where + toJSON (Derivation name outputs (DerivationInputs inputSrcs inputDrvs) system builder args env) = + object [ "name" .= name + , "outputs" .= derivationOutputsToJSON outputs + , "inputs" .= object + [ "srcs" .= inputSrcs + , "drvs" .= inputDrvs + ] + , "system" .= system + , "builder" .= builder + , "args" .= args + , "env" .= env + ] + + instance ToJSON (BuildTraceKey OutputName) where toJSON = toJSON diff --git a/hnix-store-json/tests/DerivationSpec.hs b/hnix-store-json/tests/DerivationSpec.hs new file mode 100644 index 00000000..0980324b --- /dev/null +++ b/hnix-store-json/tests/DerivationSpec.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module DerivationSpec where + +import Crypto.Hash (SHA256) +import Data.Aeson (eitherDecode) +import Data.ByteString.Lazy qualified as BSL +import Data.Dependent.Sum (DSum(..)) +import Data.Map.Monoidal qualified as MonoidalMap +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Some (Some(..)) +import Data.These (These(..)) +import Data.Vector qualified as Vector +import Paths_hnix_store_json (getDataFileName) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.Nix (forceRight) + +import System.Nix.Base (BaseEncoding(..)) +import System.Nix.ContentAddress (ContentAddressMethod(..)) +import System.Nix.Derivation + ( ChildNode(..) + , Derivation + , Derivation'(..) + , DerivationInputs(..) + , DerivedPathMap(..) + , DerivationType(..) + , InputAddressedDerivationOutput(..) + , FixedDerivationOutput(..) + , ContentAddressedDerivationOutput(..) + ) +import System.Nix.Hash (HashAlgo(..), decodeDigestWith) +import System.Nix.JSON () +import System.Nix.OutputName qualified +import System.Nix.StorePath (mkStorePathName, parseBasePathFromText) + +simpleDerivation :: Derivation +simpleDerivation = Derivation + { name = forceRight $ mkStorePathName "simple-derivation" + , outputs = DerivationType_InputAddressing :=> mempty + , inputs = DerivationInputs + { srcs = Set.singleton $ forceRight $ parseBasePathFromText "c015dhfh5l0lp6wxyvdn7bmwhbbr6hr9-dep1" + , drvs = DerivedPathMap $ MonoidalMap.singleton + (forceRight $ parseBasePathFromText "c015dhfh5l0lp6wxyvdn7bmwhbbr6hr9-dep2.drv") + (ChildNode $ This $ Set.fromList + [ forceRight $ System.Nix.OutputName.mkOutputName "cat" + , forceRight $ System.Nix.OutputName.mkOutputName "dog" + ]) + } + , platform = "wasm-sel4" + , builder = "foo" + , args = Vector.fromList ["bar", "baz"] + , env = Map.fromList [("BIG_BAD", "WOLF")] + } + +dynDepDerivation :: Derivation +dynDepDerivation = Derivation + { name = forceRight $ mkStorePathName "dyn-dep-derivation" + , outputs = DerivationType_InputAddressing :=> mempty + , inputs = DerivationInputs + { srcs = Set.singleton $ forceRight $ parseBasePathFromText "c015dhfh5l0lp6wxyvdn7bmwhbbr6hr9-dep1" + , drvs = DerivedPathMap $ MonoidalMap.singleton + (forceRight $ parseBasePathFromText "c015dhfh5l0lp6wxyvdn7bmwhbbr6hr9-dep2.drv") + (ChildNode $ These + (Set.fromList + [ forceRight $ System.Nix.OutputName.mkOutputName "cat" + , forceRight $ System.Nix.OutputName.mkOutputName "dog" + ]) + (MonoidalMap.fromList + [ ( forceRight $ System.Nix.OutputName.mkOutputName "cat" + , ChildNode $ This $ Set.singleton $ forceRight $ System.Nix.OutputName.mkOutputName "kitten" + ) + , ( forceRight $ System.Nix.OutputName.mkOutputName "goose" + , ChildNode $ This $ Set.singleton $ forceRight $ System.Nix.OutputName.mkOutputName "gosling" + ) + ]) + ) + } + , platform = "wasm-sel4" + , builder = "foo" + , args = Vector.fromList ["bar", "baz"] + , env = Map.fromList [("BIG_BAD", "WOLF")] + } + +spec :: Spec +spec = do + describe "upstream Nix test data" $ do + describe "full derivations" $ do + it "parses simple-derivation.json" $ do + path <- getDataFileName "upstream-libstore-data/derivation/simple-derivation.json" + json <- BSL.readFile path + eitherDecode json `shouldBe` Right simpleDerivation + + it "parses dyn-dep-derivation.json" $ do + path <- getDataFileName "upstream-libstore-data/derivation/dyn-dep-derivation.json" + json <- BSL.readFile path + eitherDecode json `shouldBe` Right dynDepDerivation + + describe "output types" $ do + it "parses output-inputAddressed.json" $ do + path <- getDataFileName "upstream-libstore-data/derivation/output-inputAddressed.json" + json <- BSL.readFile path + output <- case eitherDecode json of + Right output -> pure output + Left err -> fail err + + let expectedPath = forceRight $ parseBasePathFromText "c015dhfh5l0lp6wxyvdn7bmwhbbr6hr9-drv-name-output-name" + + output `shouldBe` InputAddressedDerivationOutput expectedPath + + it "parses output-caFixedFlat.json" $ do + path <- getDataFileName "upstream-libstore-data/derivation/output-caFixedFlat.json" + json <- BSL.readFile path + output <- case eitherDecode json of + Right output -> pure output + Left err -> fail err + + let expectedHash = either error id $ decodeDigestWith @SHA256 Base64 "iUUXyRY8iW7DGirb0zwGgf1fRbLA7wimTJKgP7l/OQ8=" + + output `shouldBe` FixedDerivationOutput ContentAddressMethod_Flat (HashAlgo_SHA256 :=> expectedHash) + + it "parses output-caFixedNAR.json" $ do + path <- getDataFileName "upstream-libstore-data/derivation/output-caFixedNAR.json" + json <- BSL.readFile path + output <- case eitherDecode json of + Right output -> pure output + Left err -> fail err + + let expectedHash = either error id $ decodeDigestWith @SHA256 Base64 "iUUXyRY8iW7DGirb0zwGgf1fRbLA7wimTJKgP7l/OQ8=" + + output `shouldBe` FixedDerivationOutput ContentAddressMethod_NixArchive (HashAlgo_SHA256 :=> expectedHash) + + it "parses output-caFixedText.json" $ do + path <- getDataFileName "upstream-libstore-data/derivation/output-caFixedText.json" + json <- BSL.readFile path + output <- case eitherDecode json of + Right output -> pure output + Left err -> fail err + + let expectedHash = either error id $ decodeDigestWith @SHA256 Base64 "iUUXyRY8iW7DGirb0zwGgf1fRbLA7wimTJKgP7l/OQ8=" + + output `shouldBe` FixedDerivationOutput ContentAddressMethod_Text (HashAlgo_SHA256 :=> expectedHash) + + it "parses output-caFloating.json" $ do + path <- getDataFileName "upstream-libstore-data/derivation/output-caFloating.json" + json <- BSL.readFile path + output <- case eitherDecode json of + Right output -> pure output + Left err -> fail err + + output `shouldBe` ContentAddressedDerivationOutput ContentAddressMethod_NixArchive (Some HashAlgo_SHA256) diff --git a/hnix-store-json/tests/JSONSpec.hs b/hnix-store-json/tests/JSONSpec.hs index 38ce9e0e..a0d239a4 100644 --- a/hnix-store-json/tests/JSONSpec.hs +++ b/hnix-store-json/tests/JSONSpec.hs @@ -9,6 +9,7 @@ import Test.Hspec.QuickCheck (prop) import System.Nix.Arbitrary () import System.Nix.ContentAddress (ContentAddress) +import System.Nix.Derivation (Derivation) import System.Nix.DerivedPath (DerivedPath, OutputsSpec, SingleDerivedPath) import System.Nix.JSON ({-HashJSON-}) import System.Nix.OutputName (OutputName) @@ -37,6 +38,7 @@ spec = do prop "OutputsSpec" $ roundtripsJSON @OutputsSpec prop "SingleDerivedPath" $ roundtripsJSON @SingleDerivedPath prop "DerivedPath" $ roundtripsJSON @DerivedPath + prop "Derivation" $ roundtripsJSON @Derivation prop "BuildTraceKey OutputName" $ roundtripsJSON @(BuildTraceKey OutputName) prop "Signature" $ roundtripsJSON @Signature prop "Realisation" $ roundtripsJSON @Realisation diff --git a/hnix-store-readonly/hnix-store-readonly.cabal b/hnix-store-readonly/hnix-store-readonly.cabal index 2e7345c0..212a4726 100644 --- a/hnix-store-readonly/hnix-store-readonly.cabal +++ b/hnix-store-readonly/hnix-store-readonly.cabal @@ -21,8 +21,8 @@ common commons ghc-options: -Wall default-extensions: Rank2Types - , ImportQualifiedPost , ScopedTypeVariables + , ImportQualifiedPost , TypeApplications default-language: Haskell2010 @@ -35,12 +35,9 @@ library , hnix-store-core >= 0.8 , hnix-store-nar >= 0.1 , bytestring - , constraints-extras , crypton , dependent-sum > 0.7 , mtl - , text - , unordered-containers hs-source-dirs: src test-suite readonly diff --git a/hnix-store-readonly/src/System/Nix/Store/ReadOnly.hs b/hnix-store-readonly/src/System/Nix/Store/ReadOnly.hs index 24e3d855..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 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.Nar 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 - } - -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') digestPath :: FilePath -- ^ Local `FilePath` to add diff --git a/hnix-store-readonly/tests/ReadOnlySpec.hs b/hnix-store-readonly/tests/ReadOnlySpec.hs index afab70e8..7ddfbb92 100644 --- a/hnix-store-readonly/tests/ReadOnlySpec.hs +++ b/hnix-store-readonly/tests/ReadOnlySpec.hs @@ -10,12 +10,13 @@ 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 Data.HashSet qualified import System.Nix.StorePath qualified -import System.Nix.Store.ReadOnly +import System.Nix.Store.ReadOnly () testDigest :: DSum HashAlgo Digest testDigest = HashAlgo_SHA256 :=> Crypto.Hash.hash @ByteString "testDigest" diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index ac8ffe9f..55f2ae53 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -31,8 +31,8 @@ common commons , DerivingVia , FlexibleContexts , FlexibleInstances - , GADTs , ImportQualifiedPost + , GADTs , RecordWildCards , ScopedTypeVariables , StandaloneDeriving @@ -93,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 @@ -108,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 @@ -123,6 +123,7 @@ library , exceptions , generic-arbitrary < 1.1 , hashable + , mmorph , text , time , transformers @@ -179,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 + , time + , 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 37ee012a..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 Data.Serialize qualified -- * Serializer @@ -68,21 +68,17 @@ import Data.Serialize qualified -- 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/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index 700d502d..12874619 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -5,6 +5,8 @@ module System.Nix.Store.Remote.Arbitrary where import Data.Some (Some(Some)) import System.Nix.Arbitrary () +import System.Nix.Derivation (Derivation'(..)) +import System.Nix.StorePath (StorePath(..)) import System.Nix.Store.Types (RepairMode(..)) import System.Nix.Store.Remote.Types @@ -101,7 +103,13 @@ instance Arbitrary (Some StoreRequest) where , Some . AddIndirectRoot <$> arbitrary , Some . AddTempRoot <$> arbitrary , Some <$> (BuildPaths <$> arbitrary <*> arbitrary) - , Some <$> (BuildDerivation <$> arbitrary <*> arbitrary <*> arbitrary) + , do + path <- arbitrary + drv <- arbitrary + buildMode' <- arbitrary + -- Ensure store path name matches derivation name (helps with length issues) + let path' = path { storePathName = name drv } + pure $ Some (BuildDerivation path' drv buildMode') , Some . CollectGarbage <$> arbitrary , Some . EnsurePath <$> arbitrary , pure $ Some FindRoots 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 fddd5698..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) @@ -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 743a0712..c9e3be2e 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,21 +21,32 @@ 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 + , buildResult + , gcResult + , gcRoot + , hashSet , int + , maybePathMetadata , mapErrorS + , mapS + , missing + , opSuccess , protoVersion + , storePath + , storePathName , 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 Data.ByteString qualified @@ -48,17 +59,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 +89,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 @@ -91,6 +104,61 @@ doReq = \case processOutput pure NoReply + AddTextToStore {} -> do + processOutput + sockGetS $ mapErrorS (RemoteStoreError_SerializerReply . ReplySError_PrimGet) $ storePath storeDir + + AddSignatures _path _sigs -> do + processOutput + sockGetS $ mapErrorS RemoteStoreError_SerializerReply opSuccess + + AddIndirectRoot _path -> do + processOutput + sockGetS $ mapErrorS RemoteStoreError_SerializerReply opSuccess + + AddTempRoot _path -> do + processOutput + sockGetS $ mapErrorS RemoteStoreError_SerializerReply opSuccess + + BuildPaths {} -> do + processOutput + sockGetS $ mapErrorS RemoteStoreError_SerializerReply opSuccess + + BuildDerivation {} -> do + processOutput + sockGetS + $ mapErrorS + RemoteStoreError_SerializerReply + $ buildResult storeDir pv + + CollectGarbage _gcOpts -> do + processOutput + sockGetS + $ mapErrorS + RemoteStoreError_SerializerReply + $ gcResult storeDir + + EnsurePath _path -> do + processOutput + sockGetS $ mapErrorS RemoteStoreError_SerializerReply opSuccess + + FindRoots -> do + processOutput + sockGetS + $ mapErrorS RemoteStoreError_SerializerReply + $ mapS + gcRoot + $ mapErrorS + ReplySError_PrimGet + (storePath storeDir) + + IsValidPath _path -> do + processOutput + sockGetS + $ mapErrorS + (RemoteStoreError_SerializerReply . ReplySError_PrimGet) + bool + NarFromPath _ -> do maybeSink <- getDataSink sink <- case maybeSink of @@ -107,15 +175,91 @@ doReq = \case copyToSink sink narSize soc pure NoReply - _ -> do + QueryValidPaths {} -> do processOutput - processReply + sockGetS + $ mapErrorS + (RemoteStoreError_SerializerReply . ReplySError_PrimGet) + $ hashSet (storePath storeDir) - where - processReply = sockGetS - (mapErrorS RemoteStoreError_SerializerReply - $ getReplyS @a - ) + QueryAllValidPaths -> do + processOutput + sockGetS + $ mapErrorS + (RemoteStoreError_SerializerReply . ReplySError_PrimGet) + $ hashSet (storePath storeDir) + + QuerySubstitutablePaths {} -> do + processOutput + sockGetS + $ mapErrorS + (RemoteStoreError_SerializerReply . ReplySError_PrimGet) + $ hashSet (storePath storeDir) + + + QueryPathInfo {} -> do + processOutput + sockGetS + $ mapErrorS + RemoteStoreError_SerializerReply + $ maybePathMetadata storeDir + + QueryReferrers _path -> do + processOutput + sockGetS + $ mapErrorS + (RemoteStoreError_SerializerReply . ReplySError_PrimGet) + $ hashSet (storePath storeDir) + + QueryValidDerivers _path -> do + processOutput + sockGetS + $ mapErrorS + (RemoteStoreError_SerializerReply . ReplySError_PrimGet) + $ hashSet (storePath storeDir) + + QueryDerivationOutputs _path -> do + processOutput + sockGetS + $ mapErrorS + (RemoteStoreError_SerializerReply . ReplySError_PrimGet) + $ hashSet (storePath storeDir) + + QueryDerivationOutputNames _path -> do + processOutput + sockGetS + $ mapErrorS + (RemoteStoreError_SerializerReply . ReplySError_PrimGet) + $ hashSet storePathName + + QueryPathFromHashPart _pathHashPart -> do + processOutput + sockGetS + $ mapErrorS + (RemoteStoreError_SerializerReply . ReplySError_PrimGet) + $ storePath storeDir + + QueryMissing _derivedPathSet -> do + processOutput + sockGetS + $ mapErrorS + RemoteStoreError_SerializerReply + $ missing storeDir + + OptimiseStore -> do + processOutput + sockGetS $ mapErrorS RemoteStoreError_SerializerReply opSuccess + + SyncWithGC -> do + processOutput + sockGetS $ mapErrorS RemoteStoreError_SerializerReply opSuccess + + VerifyStore {} -> do + processOutput + sockGetS + $ mapErrorS + (RemoteStoreError_SerializerReply . ReplySError_PrimGet) + bool 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 6773a8cd..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,11 +2,11 @@ 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(..)) @@ -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/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index bf1d732b..e4e1d495 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 @@ -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.ByteString (ByteString) -import Data.Dependent.Sum (DSum((:=>))) -import Data.Fixed (Uni) -import Data.Hashable (Hashable) -import Data.HashSet (HashSet) -import Data.Map (Map) -import Data.Serializer -import Data.Set (Set) -import Data.Some (Some(Some)) -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) -import Data.Time (NominalDiffTime, UTCTime) -import Data.Vector (Vector) -import Data.Word (Word8, Word32, Word64) -import GHC.Generics (Generic) -import System.Nix.Base (BaseEncoding(Base16, NixBase32)) -import System.Nix.Build (BuildMode, BuildResult(..), BuildSuccess(..), BuildFailure(..), BuildSuccessStatus(..), BuildFailureStatus(..)) -import System.Nix.ContentAddress (ContentAddress) -import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) -import System.Nix.DerivedPath (DerivedPath(..), ParseOutputsError) -import System.Nix.Hash (HashAlgo(..)) -import System.Nix.JSON () -import System.Nix.OutputName (OutputName) -import System.Nix.Realisation (BuildTraceKey, BuildTraceKeyError, Realisation(..), RealisationWithId(..)) -import System.Nix.Signature (Signature, NarSignature) -import System.Nix.FileContentAddress (FileIngestionMethod(..)) -import System.Nix.Store.Types (RepairMode(..)) -import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) -import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) -import System.Nix.Store.Remote.Types - -import Control.Monad qualified -import Control.Monad.Reader qualified 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.Coerce qualified +import Data.Dependent.Sum (DSum((:=>))) +import Data.Fixed (Uni) +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(..), BuildSuccess(..), BuildFailure(..), BuildSuccessStatus(..), BuildFailureStatus(..)) +import System.Nix.ContentAddress (ContentAddress) 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.OutputName qualified +import System.Nix.Realisation (BuildTraceKey, BuildTraceKeyError, Realisation(..), RealisationWithId(..)) import System.Nix.Realisation qualified +import System.Nix.Signature (Signature, NarSignature) import System.Nix.Signature qualified +import System.Nix.Store.Remote.Types +import System.Nix.Store.Types (RepairMode(..)) +import System.Nix.StorePath (StoreDir, InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) import System.Nix.StorePath qualified - --- | 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 +import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) 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,6 +192,7 @@ data SError , badPaddingPads :: [Word8] } | SError_ContentAddress String + | SError_DerivingPath | SError_DerivedPath ParseOutputsError | SError_BuildTraceKey BuildTraceKeyError | SError_Digest String @@ -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,65 +582,81 @@ pathMetadata = Serializer -- * OutputName -outputName :: NixSerializer r SError OutputName +outputName :: NixSerializer SError OutputName outputName = mapIsoSerializer System.Nix.OutputName.OutputName - System.Nix.OutputName.unOutputName + 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 @@ -710,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 @@ -809,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 @@ -823,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 @@ -846,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) @@ -857,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 @@ -868,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 @@ -887,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 @@ -909,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 $ @@ -928,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 @@ -956,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 @@ -964,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 @@ -972,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 @@ -985,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 @@ -1001,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 @@ -1014,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 @@ -1025,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 @@ -1042,7 +999,7 @@ trustedFlag = Serializer -- * Worker protocol -storeText :: NixSerializer r SError StoreText +storeText :: NixSerializer SError StoreText storeText = Serializer { getS = do storeTextName <- getS storePathName @@ -1053,7 +1010,7 @@ storeText = Serializer putS text storeTextText } -workerOp :: NixSerializer r SError WorkerOp +workerOp :: NixSerializer SError WorkerOp workerOp = enum -- * Request @@ -1062,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 @@ -1085,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 @@ -1096,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 @@ -1133,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) @@ -1153,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 @@ -1212,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 @@ -1225,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 @@ -1347,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 @@ -1373,7 +1328,6 @@ storeRequest = Serializer data ReplySError = ReplySError_PrimGet SError - | ReplySError_PrimPut SError | ReplySError_BuildTraceKey SError | ReplySError_GCResult SError | ReplySError_Metadata SError @@ -1385,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 @@ -1406,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 () @@ -1417,37 +1365,38 @@ noop ret = Serializer -- *** Realisation -buildTraceKeyTyped :: NixSerializer r ReplySError (BuildTraceKey OutputName) +buildTraceKeyTyped :: NixSerializer ReplySError (BuildTraceKey OutputName) buildTraceKeyTyped = mapErrorS ReplySError_BuildTraceKey $ mapPrismSerializer - ( Data.Bifunctor.first SError_BuildTraceKey + 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.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 - statusWord <- mapGetER $ getS enum errorMessage <- mapGetER $ getS maybeText @@ -1495,17 +1444,15 @@ buildResult = Serializer } , putS = \BuildResult{..} -> do - pv <- Control.Monad.Reader.asks hasProtoVersion - let (statusWord, errorMessage, isNonDeterministic, builtOutputs) = case buildResultStatus of Right (BuildSuccess st bo) -> (successStatusToWire st, Nothing, False, bo) Left (BuildFailure st em nd) -> (failureStatusToWire st, Just em, nd, mempty) - mapPutER $ putS enum statusWord - mapPutER $ putS maybeText errorMessage + putS enum statusWord + putS maybeText errorMessage Control.Monad.when (protoVersion_minor pv >= 29) $ do putS int buildResultTimesBuilt - mapPutER $ putS bool isNonDeterministic + putS bool isNonDeterministic putS time buildResultStartTime putS time buildResultStopTime Control.Monad.when (protoVersion_minor pv >= 28) @@ -1564,29 +1511,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 } @@ -1595,21 +1542,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 } @@ -1617,15 +1564,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 ffddeaee..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,10 +21,11 @@ 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) @@ -39,7 +40,7 @@ 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 e4e12e46..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,14 +1,14 @@ 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 Control.Exception qualified import Data.ByteString qualified @@ -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/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 09b963ec..4cdecb1b 100644 --- a/hnix-store-remote/tests/EnumSpec.hs +++ b/hnix-store-remote/tests/EnumSpec.hs @@ -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 d0ea5b79..73d38bf0 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -4,7 +4,6 @@ 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) @@ -13,8 +12,7 @@ import Data.Time.Clock.POSIX qualified import System.Nix.Arbitrary () import System.Nix.Build (BuildResult(..), BuildSuccess(..), BuildFailure(..)) -import System.Nix.Derivation (Derivation(inputDrvs)) -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(..)) @@ -23,45 +21,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) @@ -73,7 +72,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 { buildResultStatus = case buildResultStatus x of Right (BuildSuccess st _bo) -> Right (BuildSuccess st mempty) Left (BuildFailure st em _nd) -> Left (BuildFailure st em False) @@ -87,7 +86,7 @@ spec = parallel $ do ) prop "= 1.28" $ \sd -> - roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd (ProtoVersion 1 28)) + roundtripS (buildResult sd $ ProtoVersion 1 28) . (\x -> x { buildResultStatus = case buildResultStatus x of Right s -> Right s Left (BuildFailure st em _nd) -> Left (BuildFailure st em False) @@ -102,14 +101,14 @@ 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 { buildResultCpuUser = Nothing , buildResultCpuSystem = Nothing } ) prop "StorePath" $ - roundtripSReader @StoreDir storePath + roundtripSReader storePath prop "StorePathHashPart" $ roundtripS storePathHashPart @@ -118,7 +117,7 @@ spec = parallel $ do roundtripS storePathName prop "Metadata (StorePath)" $ - roundtripSReader @StoreDir pathMetadata + roundtripSReader pathMetadata prop "Some HashAlgo" $ roundtripS someHashAlgo @@ -129,11 +128,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 @@ -149,7 +148,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 @@ -162,18 +161,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 f180e11b..330bdc9d 100644 --- a/hnix-store-tests/hnix-store-tests.cabal +++ b/hnix-store-tests/hnix-store-tests.cabal @@ -26,9 +26,9 @@ common commons DerivingStrategies , DerivingVia , FlexibleInstances - , ImportQualifiedPost , ScopedTypeVariables , StandaloneDeriving + , ImportQualifiedPost , RecordWildCards , TypeApplications , LambdaCase @@ -98,3 +98,4 @@ test-suite props , attoparsec , text , hspec + , QuickCheck diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs index 9910dee9..49d7014e 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs @@ -1,19 +1,150 @@ +{-# 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.Map (Map) +import Data.Map qualified +import Data.Set (Set) +import Data.Some +import Data.Text import Data.Text.Arbitrary () 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.DerivedPath +import System.Nix.Derivation +import System.Nix.OutputName +import System.Nix.Arbitrary.DerivedPath () +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 = + if availableSpace < 1 + then + out + else do + len <- choose (1, availableSpace) + oneof [out, shorten len <$> arbitrary] + where + nameLen = Data.Text.length (unStorePathName drvName) + availableSpace = 211 - nameLen - 1 -- for the - in - + out = pure $ toOutputName $ pack "out" + shorten n = toOutputName . Data.Text.take n . unStorePathName . unOutputName + toOutputName = OutputName . either undefined id . mkStorePathName + +-- | 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 ContentAddressMethod_Text HashAlgo_SHA256 = True +ensureValidMethodAlgo ContentAddressMethod_Text _ = False +ensureValidMethodAlgo _ _ = 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 + +instance Arbitrary DerivedPathMap where + arbitrary = foldMap (uncurry derivedPathMapFromSingleDerivedPathBuilt) <$> (arbitrary :: Gen (Data.Set.Set (SingleDerivedPath, OutputName))) + +{- +deriving via GenericArbitrary DerivedPathMap + instance Arbitrary DerivedPathMap + +instance Arbitrary ChildNode where + -- Scale down exponentially, or the resulting tree may explode in size. + arbitrary = scale (`div` 5) $ do + oneof [ + ChildNode . This . Data.Set.fromList <$> ((:) <$> arbitrary <*> arbitrary) + , ChildNode . That . Data.Map.Monoidal.fromList <$> ((:) <$> arbitrary <*> arbitrary) + ] + +-- 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/tests/DerivationSpec.hs b/hnix-store-tests/tests/DerivationSpec.hs index 604eb00d..c6bb76e7 100644 --- a/hnix-store-tests/tests/DerivationSpec.hs +++ b/hnix-store-tests/tests/DerivationSpec.hs @@ -1,27 +1,34 @@ 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 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 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 + +-- -- | Useful for debugging +-- instance MonadFail (Either String) where +-- fail = Left diff --git a/overlay.nix b/overlay.nix index 1247d93d..820b01b7 100644 --- a/overlay.nix +++ b/overlay.nix @@ -15,18 +15,6 @@ let } // (lib.filterAttrs (n: v: n != "url") x)); in { - # srk 2025-09-03: until revised version lands in unstable - # (due to filepath bound https://github.com/Gabriella439/Haskell-Nix-Derivation-Library/pull/29) - nix-derivation = hself.callHackageDirect - { pkg = "nix-derivation"; - ver = "1.1.3"; - sha256 = "sha256-pklIwd0Atp45AT9x2n3PWAV7tFRqTzv89ViG2iAjoe0="; - rev = - { revision = "2"; - sha256 = "sha256-Vv0NIHevaQOyFWBn79Q8OAYZa/Yhas/N1lBHfjANAm4="; - }; - } {}; - hnix-store-core = lib.pipe (hself.callCabal2nix "hnix-store-core" ./hnix-store-core/hnix-store-core.cabal {}) @@ -41,6 +29,12 @@ in (drv: drv.overrideAttrs (old: { src = ./hnix-store-db; })) haskellLib.compose.buildFromSdist ]; + hnix-store-aterm = + lib.pipe + (hself.callCabal2nix "hnix-store-aterm" ./hnix-store-aterm {}) + [ + haskellLib.compose.buildFromSdist + ]; hnix-store-json = let # Include the JSON test data files from upstream Nix that we need @@ -52,6 +46,7 @@ in (lib.fileset.fileFilter (file: file.hasExt "json") ./upstream-nix/src/libstore-tests/data/build-result) (lib.fileset.fileFilter (file: file.hasExt "json") ./upstream-nix/src/libstore-tests/data/content-address) (lib.fileset.fileFilter (file: file.hasExt "json") ./upstream-nix/src/libstore-tests/data/derived-path) + (lib.fileset.fileFilter (file: file.hasExt "json") ./upstream-nix/src/libstore-tests/data/derivation) (lib.fileset.fileFilter (file: file.hasExt "json") ./upstream-nix/src/libstore-tests/data/outputs-spec) (lib.fileset.fileFilter (file: file.hasExt "json") ./upstream-nix/src/libstore-tests/data/realisation) (lib.fileset.fileFilter (file: file.hasExt "json") ./upstream-nix/src/libstore-tests/data/store-path)