hnix-store-remote 0.6.0.0 → 0.7.0.0

raw patch · 53 files changed

+6019/−1387 lines, 53 filesdep +QuickCheckdep +aesondep +cerealdep −binarydep −cryptonitedep −nix-derivationdep ~basedep ~hnix-store-coredep ~unixnew-component:exe:build-derivationnew-component:exe:remote-readmePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, aeson, cereal, concurrency, crypton, data-default-class, dependent-sum, dependent-sum-template, dlist, exceptions, generic-arbitrary, hashable, hnix-store-json, hnix-store-nar, hnix-store-tests, some, transformers, vector

Dependencies removed: binary, cryptonite, nix-derivation, quickcheck-text, relude, tasty, tasty-hspec, tasty-quickcheck

Dependency ranges changed: base, hnix-store-core, unix

API changes (from Hackage documentation)

Files

• CHANGELOG.md +71/−0
• ChangeLog.md +0/−52
• README.lhs +36/−0
• README.md +13/−5
• app/BuildDerivation.hs +25/−0
• hnix-store-remote.cabal +172/−87
• src/Data/Serializer.hs +214/−0
• src/Data/Serializer/Example.hs +329/−0
• src/System/Nix/Store/Remote.hs +180/−290
• src/System/Nix/Store/Remote/Arbitrary.hs +137/−0
• src/System/Nix/Store/Remote/Binary.hs +0/−52
• src/System/Nix/Store/Remote/Builders.hs +0/−36
• src/System/Nix/Store/Remote/Client.hs +279/−0
• src/System/Nix/Store/Remote/Client/Core.hs +229/−0
• src/System/Nix/Store/Remote/Logger.hs +87/−73
• src/System/Nix/Store/Remote/MonadStore.hs +390/−0
• src/System/Nix/Store/Remote/Parsers.hs +0/−51
• src/System/Nix/Store/Remote/Protocol.hs +0/−215
• src/System/Nix/Store/Remote/Serializer.hs +1567/−0
• src/System/Nix/Store/Remote/Server.hs +365/−0
• src/System/Nix/Store/Remote/Socket.hs +101/−0
• src/System/Nix/Store/Remote/Types.hs +31/−75
• src/System/Nix/Store/Remote/Types/Activity.hs +55/−0
• src/System/Nix/Store/Remote/Types/CheckMode.hs +11/−0
• src/System/Nix/Store/Remote/Types/GC.hs +55/−0
• src/System/Nix/Store/Remote/Types/Handshake.hs +37/−0
• src/System/Nix/Store/Remote/Types/Logger.hs +108/−0
• src/System/Nix/Store/Remote/Types/NoReply.hs +8/−0
• src/System/Nix/Store/Remote/Types/ProtoVersion.hs +27/−0
• src/System/Nix/Store/Remote/Types/Query.hs +5/−0
• src/System/Nix/Store/Remote/Types/Query/Missing.hs +18/−0
• src/System/Nix/Store/Remote/Types/StoreConfig.hs +61/−0
• src/System/Nix/Store/Remote/Types/StoreReply.hs +61/−0
• src/System/Nix/Store/Remote/Types/StoreRequest.hs +202/−0
• src/System/Nix/Store/Remote/Types/StoreText.hs +12/−0
• src/System/Nix/Store/Remote/Types/SubstituteMode.hs +11/−0
• src/System/Nix/Store/Remote/Types/SuccessCodeReply.hs +10/−0
• src/System/Nix/Store/Remote/Types/TrustedFlag.hs +11/−0
• src/System/Nix/Store/Remote/Types/Verbosity.hs +17/−0
• src/System/Nix/Store/Remote/Types/WorkerMagic.hs +27/−0
• src/System/Nix/Store/Remote/Types/WorkerOp.hs +59/−0
• src/System/Nix/Store/Remote/Util.hs +0/−167
• tests-io/DataSink.hs +26/−0
• tests-io/Main.hs +12/−0
• tests-io/NixDaemonSpec.hs +521/−0
• tests-io/SampleNar.hs +89/−0
• tests/Data/SerializerSpec.hs +43/−0
• tests/Driver.hs +1/−9
• tests/EnumSpec.hs +137/−0
• tests/NixDaemon.hs +0/−262
• tests/NixSerializerSpec.hs +169/−0
• tests/Spec.hs +0/−1
• tests/Util.hs +0/−12

@@ -0,0 +1,71 @@+# [0.7.0.0](https://github.com/haskell-nix/hnix-store/compare/remote-0.6.0.0...remote-0.7.0.0) 2024-07-31++* Changes:+    * `StorePath` no longer carries `storePathRoot` field and we+      have a stand-alone `StoreDir` type instead to be used instead of `FilePath`+      when store root directory is needed as a context.+      Fore `-remote`, this affects `runStoreOpts` and its variants [#216](https://github.com/haskell-nix/hnix-store/pull/216)+    * The old `MonadStore` is now deprecated and aliased to `RemoteStoreT IO`+    * All store operations now use `MonadRemoteStore` typeclass, which `RemoteStoreT` is an instance of+    * Couple of `Bool` parameters switched to enums++* Additions+    * `addToStoreNAR` store operation [#277](https://github.com/haskell-nix/hnix-store/pull/277)+    * `narFromPath` store operation [#279](https://github.com/haskell-nix/hnix-store/pull/279)+    * Initial server-side support with proxy daemon acting as MITM proxy,+      which allows for testing of both sides of the remote store protocol++The library stability is not quite there yet and should be considered experimental.++# [0.6.0.0](https://github.com/haskell-nix/hnix-store/compare/remote-0.5.0.0...remote-0.6.0.0) 2021-06-06++* Changes:+  * `System.Nix.Store.Remote` [#179](https://github.com/haskell-nix/hnix-store/pull/179)+    * `addToStore` no longer accepts `FilePath` as its second argument but uses+      more generic `NarSource` [(NarSource PR)](https://github.com/haskell-nix/hnix-store/pull/177)++# [0.5.0.0](https://github.com/haskell-nix/hnix-store/compare/0.4.3.0...remote-0.5.0.0) 2021-06-11++* Changes:+  * `System.Nix.Store.Remote` [#161](https://github.com/haskell-nix/hnix-store/pull/161)+    * `addToStore`: constraint of `ValidAlgo a` removed in favour of constraint on `cryptonite: HashAlgorithm a` through constraint `NamedAlgo a`.+    * `queryPathFromHashPart`: 1st arg changed from `Digest StorePathHashAlgo` to `StorePathHashPart`, for details: [hnix-store-core 0.5.0.0 ChangeLog](https://hackage.haskell.org/package/hnix-store-core-0.5.0.0/changelog).++# [0.4.3.0](https://github.com/haskell-nix/hnix-store/compare/0.4.2.0...0.4.3.0) 2021-05-30++Nothing (it is tandem `hnix-store-core` fix release)++# [0.4.2.0](https://github.com/haskell-nix/hnix-store/compare/0.4.1.0...0.4.2.0) 2021-03-12++* Additions:+  * Cabal now properly states `tasty-discover` as `build-tool-depends` [#130](https://github.com/haskell-nix/hnix-store/pull/130)+  * added explicit `hie.yml` cradle description for `cabal` to help Haskell Language Server to work with monorepo. [#132](https://github.com/haskell-nix/hnix-store/pull/132)+  * Nix dev env: removed GHC 8.6.5 support, afaik it is not even in Nixpkgs anymore [#136](https://github.com/haskell-nix/hnix-store/pull/136)++# [0.4.1.0](https://github.com/haskell-nix/hnix-store/compare/0.4.0.0...0.4.1.0) 2021-01-16++* `System.Nix.Store.Remote`: module API now re-exports `System.Nix.Store.Remote.Types` API+* Big clean-up of dependencies.++# [0.4.0.0](https://github.com/haskell-nix/hnix-store/compare/0.3.0.0...0.4.0.0) 2020-12-30++* `hnix-store-core` compatibility++# 0.3.0.0 -- 2020-11-29++* Restored most store API functions except `addToStoreNar`+* Added `buildDerivation`++# 0.2.0.0 -- skipped++* `hnix-store-core` release only++# 0.1.0.0  -- 2019-03-18++* First version.++---++`hnix-store-remote` uses [PVP Versioning][1].++[1]: https://pvp.haskell.org

@@ -1,52 +0,0 @@-# Revision history for hnix-store-remote--## [0.6.0.0](https://github.com/haskell-nix/hnix-store/compare/remote-0.5.0.0...remote-0.6.0.0) 2021-06-06--* Breaking:-  * [(link)](https://github.com/haskell-nix/hnix-store/pull/179) `System.Nix.Store.Remote`:-    * `addToStore` no longer accepts `FilePath` as its second argument but uses-      more generic `NarSource` [(NarSource PR)](https://github.com/haskell-nix/hnix-store/pull/177)--## [0.5.0.0](https://github.com/haskell-nix/hnix-store/compare/0.4.3.0...remote-0.5.0.0) 2021-06-11--* Breaking:-  * [(link)](https://github.com/haskell-nix/hnix-store/commit/3b948d112aa9307b0451258f28c7ee5dc86b24c7) `System.Nix.Store.Remote`:-    * `addToStore`: constraint of `ValidAlgo a` removed in favour of constraint on `cryptonite: HashAlgorithm a` through constraint `NamedAlgo a`.-    * `queryPathFromHashPart`: 1st arg changed from `Digest StorePathHashAlgo` to `StorePathHashPart`, for details: [hnix-store-core 0.5.0.0 ChangeLog](https://hackage.haskell.org/package/hnix-store-core-0.5.0.0/changelog).--## [0.4.3.0](https://github.com/haskell-nix/hnix-store/compare/0.4.2.0...0.4.3.0) 2021-05-30--Nothing (it is tandem `hnix-store-core` fix release)--## [0.4.2.0](https://github.com/haskell-nix/hnix-store/compare/0.4.1.0...0.4.2.0) 2021-03-12--* Additional:--  * [(link)](https://github.com/haskell-nix/hnix-store/commit/5d03ffc43cde9448df05e84838ece70cc83b1b6c) Cabal now properly states `tasty-discover` as `build-tool-depends`.--  * [(link)](https://github.com/haskell-nix/hnix-store/commit/b5ad38573d27e0732d0fadfebd98de1f753b4f07) added explicit `hie.yml` cradle description for `cabal` to help Haskell Language Server to work with monorepo.--  * [(link)](https://github.com/haskell-nix/hnix-store/commit/cf04083aba98ad40d183d1e26251101816cc07ae) Nix dev env: removed GHC 8.6.5 support, afaik it is not even in Nixpkgs anymore.---## [0.4.1.0](https://github.com/haskell-nix/hnix-store/compare/0.4.0.0...0.4.1.0) 2021-01-16--* `System.Nix.Store.Remote`: module API now re-exports `System.Nix.Store.Remote.Types` API-* Big clean-up of dependencies.--## [0.4.0.0](https://github.com/haskell-nix/hnix-store/compare/0.3.0.0...0.4.0.0) 2020-12-30--* `hnix-store-core` compatibility--## 0.3.0.0 -- 2020-11-29--* Restored most store API functions except `addToStoreNar`-* Added `buildDerivation`--## 0.2.0.0 -- skipped--* `hnix-store-core` release only--## 0.1.0.0  -- 2019-03-18--* First version.

@@ -0,0 +1,36 @@+# hnix-store-remote++[Nix] worker protocol implementation for interacting with remote Nix store+via `nix-daemon`.++[Nix]: https://nixos.org/nix++## API++[System.Nix.Store.Remote]: ./src/System/Nix/Store/Remote.hs++## Example++```haskell+{-# LANGUAGE OverloadedStrings #-}++import System.Nix.StorePath (mkStorePathName)+import System.Nix.Store.Remote++main :: IO ()+main = do+  runStore $ do+    syncWithGC+    roots <- findRoots++    res <- case mkStorePathName "hnix-store" of+      Left e -> error (show e)+      Right name ->+        addTextToStore+         (StoreText name "Hello World!")+         mempty+         RepairMode_DontRepair++    pure (roots, res)+  >>= print+```

@@ -12,17 +12,25 @@ ## Example  ```haskell+{-# LANGUAGE OverloadedStrings #-} -import Control.Monad.IO.Class (liftIO)-import Data.HashSet as HS+import System.Nix.StorePath (mkStorePathName) import System.Nix.Store.Remote +main :: IO () main = do   runStore $ do     syncWithGC     roots <- findRoots-    liftIO $ print roots -    res <- addTextToStore "hnix-store" "test" (HS.fromList []) False-    liftIO $ print res+    res <- case mkStorePathName "hnix-store" of+      Left e -> error (show e)+      Right name ->+        addTextToStore+         (StoreText name "Hello World!")+         mempty+         RepairMode_DontRepair++    pure (roots, res)+  >>= print ```

@@ -0,0 +1,25 @@+{-# LANGUAGE LambdaCase #-}+module Main where++import Data.Default.Class (Default(def))++import qualified Data.Text+import qualified System.Environment+import qualified System.Nix.Build+import qualified System.Nix.StorePath+import qualified System.Nix.Store.Remote++main :: IO ()+main = System.Environment.getArgs >>= \case+  [filename] -> do+    case System.Nix.StorePath.parsePathFromText def (Data.Text.pack filename) of+      Left e -> error $ show e+      Right p -> do+        out <-+            System.Nix.Store.Remote.runStore+          $ System.Nix.Store.Remote.buildDerivation+              p+              System.Nix.Build.BuildMode_Normal+        print out+  _ -> error "No input derivation file"+

@@ -1,23 +1,51 @@ cabal-version:       2.2 name:                hnix-store-remote-version:             0.6.0.0+version:             0.7.0.0 synopsis:            Remote hnix store description:         Implementation of the nix store using the daemon protocol. homepage:            https://github.com/haskell-nix/hnix-store license:             Apache-2.0 license-file:        LICENSE-author:              Richard Marko+author:              Sorki maintainer:          srk@48.io-copyright:           2018 Richard Marko+copyright:           2018 Sorki category:            Nix build-type:          Simple-extra-source-files:  ChangeLog.md, README.md+extra-doc-files:+    CHANGELOG.md+extra-source-files:+    README.md+  , README.lhs -Common commons-  if impl(ghc >= 8.10)-    ghc-options:  -Wall -Wunused-packages-  else-    ghc-options:  -Wall+common commons+  ghc-options:  -Wall+  default-extensions:+      DataKinds+    , DefaultSignatures+    , DeriveGeneric+    , DeriveDataTypeable+    , DeriveFunctor+    , DeriveFoldable+    , DeriveTraversable+    , DeriveLift+    , DerivingVia+    , FlexibleContexts+    , FlexibleInstances+    , GADTs+    , RecordWildCards+    , ScopedTypeVariables+    , StandaloneDeriving+    , TypeApplications+    , TypeOperators+    , TypeSynonymInstances+    , InstanceSigs+    , KindSignatures+    , MultiParamTypeClasses+    , TupleSections+    , LambdaCase+    , BangPatterns+    , ViewPatterns+  default-language: Haskell2010  flag io-testsuite   default:@@ -26,117 +54,174 @@     Enable testsuite, which requires external     binaries and Linux namespace support. +flag build-derivation+  default:+    False+  description:+    Build build-derivation executable++flag build-readme+  default:+    False+  description:+    Build README.lhs example+ library   import: commons   exposed-modules:-      System.Nix.Store.Remote-    , System.Nix.Store.Remote.Binary-    , System.Nix.Store.Remote.Builders+      Data.Serializer+    , Data.Serializer.Example+    , System.Nix.Store.Remote+    , System.Nix.Store.Remote.Arbitrary+    , System.Nix.Store.Remote.Client+    , System.Nix.Store.Remote.Client.Core     , System.Nix.Store.Remote.Logger-    , System.Nix.Store.Remote.Parsers-    , System.Nix.Store.Remote.Protocol+    , System.Nix.Store.Remote.MonadStore+    , System.Nix.Store.Remote.Serializer+    , System.Nix.Store.Remote.Server+    , System.Nix.Store.Remote.Socket     , System.Nix.Store.Remote.Types-    , System.Nix.Store.Remote.Util+    , System.Nix.Store.Remote.Types.Activity+    , System.Nix.Store.Remote.Types.CheckMode+    , System.Nix.Store.Remote.Types.GC+    , System.Nix.Store.Remote.Types.Handshake+    , System.Nix.Store.Remote.Types.Logger+    , System.Nix.Store.Remote.Types.NoReply+    , System.Nix.Store.Remote.Types.ProtoVersion+    , System.Nix.Store.Remote.Types.Query+    , 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+    , System.Nix.Store.Remote.Types.TrustedFlag+    , System.Nix.Store.Remote.Types.Verbosity+    , System.Nix.Store.Remote.Types.WorkerMagic+    , System.Nix.Store.Remote.Types.WorkerOp    build-depends:       base >=4.12 && <5-    , relude >= 1.0+    , hnix-store-core >= 0.8 && <0.9+    , hnix-store-json >= 0.1+    , hnix-store-nar >= 0.1+    , hnix-store-tests >= 0.1+    , aeson     , attoparsec-    , binary     , bytestring+    , cereal     , containers-    , cryptonite+    , concurrency+    , crypton+    , data-default-class+    , dependent-sum > 0.7+    , dependent-sum-template >= 0.2.0.1 && < 0.3+--    , directory+    , dlist >= 1.0+    , exceptions+    , generic-arbitrary < 1.1+    , hashable     , text     , time+    , transformers     , network-    , nix-derivation >= 1.1.1 && <2     , mtl+    , QuickCheck     , unordered-containers-    , hnix-store-core >= 0.6 && <0.7-  mixins:-      base hiding (Prelude)-    , relude (Relude as Prelude)-    , relude-  default-extensions:-      OverloadedStrings-    , DeriveGeneric-    , DeriveDataTypeable-    , DeriveFunctor-    , DeriveFoldable-    , DeriveTraversable-    , DeriveLift-    , FlexibleContexts-    , FlexibleInstances-    , StandaloneDeriving-    , TypeApplications-    , TypeSynonymInstances-    , InstanceSigs-    , MultiParamTypeClasses-    , TupleSections-    , LambdaCase-    , BangPatterns-    , ViewPatterns+    , unix >= 2.7+    , vector   hs-source-dirs:      src-  default-language:    Haskell2010   ghc-options:         -Wall -test-suite hnix-store-remote-tests-  import: commons+executable build-derivation+  if !flag(build-derivation)+    buildable: False+  build-depends:+      base >=4.12 && <5+    , hnix-store-core+    , hnix-store-remote+    , data-default-class+    , text+  default-language: Haskell2010+  main-is: BuildDerivation.hs+  hs-source-dirs:      app+  ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N" -  if !flag(io-testsuite)+executable remote-readme+  if !flag(build-readme)     buildable: False-    ghc-options:       -rtsopts -fprof-auto+  build-depends:+      base >=4.12 && <5+    , hnix-store-core+    , hnix-store-remote+  build-tool-depends:+      markdown-unlit:markdown-unlit+  default-language: Haskell2010+  main-is: README.lhs+  ghc-options: -pgmL markdown-unlit -Wall +test-suite remote+  import: commons   type:              exitcode-stdio-1.0   main-is:           Driver.hs-  other-modules:-      NixDaemon-    , Spec-    , Util   hs-source-dirs:    tests+  ghc-options:       -Wall -threaded -rtsopts "-with-rtsopts -N"+  other-modules:+      Data.SerializerSpec+      EnumSpec+      NixSerializerSpec   build-tool-depends:-    tasty-discover:tasty-discover+    hspec-discover:hspec-discover   build-depends:-      base-    , relude-    , hnix-store-core >= 0.3+      base >=4.12 && <5+    , hnix-store-core     , hnix-store-remote+    , hnix-store-tests+    , bytestring+    , crypton+    , some > 1.0.5 && < 2+    , time+    , hspec+    , QuickCheck++test-suite remote-io+  import: commons++  if !flag(io-testsuite) || os(darwin)+    buildable: False++  type:              exitcode-stdio-1.0+  main-is:           Main.hs+  hs-source-dirs:    tests-io+  -- See https://github.com/redneb/hs-linux-namespaces/issues/3+  ghc-options:       -rtsopts -fprof-auto "-with-rtsopts -V0"+  other-modules:+      DataSink+    , NixDaemonSpec+    , SampleNar+  build-depends:+      base >=4.12 && <5+    , hnix-store-core+    , hnix-store-nar+    , hnix-store-remote+    , hnix-store-tests+    , bytestring+    , concurrency     , containers-    , cryptonite+    , crypton+    , data-default-class+    , dependent-sum     , directory-    , process+    , exceptions     , filepath-    , hspec-expectations-lifted-    , quickcheck-text-    , tasty     , hspec-    , tasty-hspec-    , tasty-quickcheck+    , hspec-expectations-lifted     , linux-namespaces+    , process+    , some     , temporary+    , text+    , time     , unix     , unordered-containers-  mixins:-      base hiding (Prelude)-    , relude (Relude as Prelude)-    , relude-  default-extensions:-      OverloadedStrings-    , DeriveGeneric-    , DeriveDataTypeable-    , DeriveFunctor-    , DeriveFoldable-    , DeriveTraversable-    , DeriveLift-    , FlexibleContexts-    , FlexibleInstances-    , StandaloneDeriving-    , TypeApplications-    , TypeSynonymInstances-    , InstanceSigs-    , MultiParamTypeClasses-    , TupleSections-    , LambdaCase-    , BangPatterns-    , ViewPatterns-  default-language: Haskell2010

@@ -0,0 +1,214 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-|+Description : Serializer data type+Copyright   : (c) John Ericson, 2023+                  Sorki, 2023+Stability   : experimental++@Serializer@ ties @Get@ and @PutM@ monads+into a single datatype and allows+transforming both monads with a monad transformer+for adding extra layers like @ExceptT@+(for example when @putS@ can fail due to unsupported+version of a protocol) or @ReaderT@ (when we need+to serialize a data type based differently based+on a protocol version).++See "Data.Serializer.Example"+-}++module Data.Serializer+  (+  -- * Serializer+    Serializer(..)+  -- ** Runners+  , runGetS+  , runPutS+  -- * Simple serializer+  , SimpleSerializer+  -- ** Simple runners+  , runGetSimple+  , runPutSimple+  -- * From Get/Put, Serialize+  , lift2+  , liftSerialize+  -- * Combinators+  , mapIsoSerializer+  , mapPrismSerializer+  , tup+  -- * Utility+  , GetSerializerError(..)+  , transformGetError+  , transformPutError+  -- * Re-exports+  , Get+  , PutM+  ) where++#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.Trans.Identity (IdentityT, runIdentityT)+import Data.ByteString (ByteString)+import Data.Serialize (Serialize)+import Data.Serialize.Get (Get, runGet)+import Data.Serialize.Put (Putter, PutM, runPutM)++import qualified Data.Serialize++-- * Serializer++-- | @Serializer@ ties @Get@ and @PutM@ monads+-- into a single datatype and allows+-- transforming the monads with a monad transformer+-- for e.g. adding @ExceptT@ or @ReaderT@ layers.+data Serializer t a = Serializer+  { getS :: t Get a+  , putS :: a -> t PutM ()+  }++-- ** Runners++-- | Runner for putS of @Serializer@+runPutS+  :: ( Monad (t PutM)+     , MonadTrans t+     )+  => Serializer t a        -- ^ Serializer+  -> (t PutM () -> PutM b) -- ^ Tranformer runner+  -> a                     -- ^ Value to (out)put+  -> (b, ByteString)+runPutS s run a = runPutM $ run $ (putS s) a++-- | Runner for getS of @Serializer@+runGetS+  :: ( Monad (t Get)+     , MonadTrans t+     )+  => Serializer t a     -- ^ Serializer+  -> (t Get a -> Get b) -- ^ Tranformer runner+  -> ByteString         -- ^ ByteString to parse+  -> Either String b+runGetS s run b = runGet (run (getS s)) b++-- * Simple serializer++-- | Simple @Serializer@+type SimpleSerializer a = Serializer IdentityT a++-- ** Simple runners++-- | Runner for getS of @SimpleSerializer@+runGetSimple+  :: SimpleSerializer a+  -> ByteString+  -> Either String a+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@+lift2+  :: forall a t+   . MonadTrans t+  => Get a+  -> Putter a+  -> Serializer t a+lift2 f g = Serializer+  { getS = lift f+  , putS = lift . g+  }++-- | Lift @Serialize a@ instance into @Serializer@+liftSerialize+  :: ( Serialize a+     , MonadTrans t+     )+  => Serializer t a+liftSerialize =+  lift2+    Data.Serialize.get+    Data.Serialize.put++-- * Combinators++-- | Map over @Serializer@+mapIsoSerializer+  :: Functor (t Get)+  => (a -> b) -- ^ Map over @getS@+  -> (b -> a) -- ^ Map over @putS@+  -> Serializer t a+  -> Serializer t b+mapIsoSerializer f g s = Serializer+  { getS = f <$> getS s+  , putS = putS s . g+  }++-- | 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@+  -> Serializer t a+  -> Serializer t b+mapPrismSerializer f g s = Serializer+  { getS = either throwError pure . f =<< getS s+  , putS = putS s . g+  }++-- | Tuple combinator+tup+  :: ( Applicative (t Get)+     , Monad (t PutM)+     )+  => Serializer t a+  -> Serializer t b+  -> Serializer t (a, b)+tup a b = Serializer+  { getS = liftA2 (,) (getS a) (getS b)+  , putS = \(x, y) -> do+      putS a x+      putS b y+  }++-- * Utilities++-- | Wrapper for both GetS errors+--+--   * the one that occurs when @fail@ is called+--   * custom one when @ExceptT@ is used+data GetSerializerError customGetError+  = SerializerError_GetFail String+  | SerializerError_Get customGetError+  deriving (Eq, Ord, Show)++-- | Helper for transforming nested Eithers+-- into @GetSerializerError@ wrapper+transformGetError+  :: Either String (Either customGetError b)+  -> Either (GetSerializerError customGetError) b+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

@@ -0,0 +1,329 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.Serializer.Example+  (+  -- * Simple protocol+    OpCode(..)+  , Cmd(..)+  -- * Cmd Serializer+  , cmdS+  -- * Runners+  , runG+  , 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+  , runPRest+  ) where++import Control.Monad.Except (MonadError, throwError)+import Control.Monad.Reader (MonadReader, ask)+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.ByteString (ByteString)+import Data.Int (Int8)+import Data.GADT.Show (GShow(..), defaultGshowsPrec)+import Data.Kind (Type)+import Data.Type.Equality (TestEquality(..), (:~:)(Refl))+import Data.Serialize.Get (Get, getInt8)+import Data.Serialize.Put (Putter, PutM, putInt8)+import Data.Serializer+  ( Serializer(..)+  , GetSerializerError+  , runGetS+  , runPutS+  , transformGetError+  , transformPutError+  )+import Data.Some (Some(..))+import GHC.Generics (Generic)++import Test.QuickCheck (Arbitrary(..), oneof)++-- * Simple protocol++-- | OpCode used to differentiate between operations+data OpCode = OpCode_Int | OpCode_Bool+  deriving (Bounded, Eq, Enum, Generic, Ord, Show)++-- | Protocol operations+data Cmd :: Type -> Type where+  Cmd_Int :: Int8 -> Cmd Int8+  Cmd_Bool :: Bool -> Cmd Bool++deriving instance Eq (Cmd a)+deriving instance Show (Cmd a)++instance GShow Cmd where+  gshowsPrec = defaultGshowsPrec++instance TestEquality Cmd where+    testEquality (Cmd_Int _) (Cmd_Int _) = Just Refl+    testEquality (Cmd_Bool _) (Cmd_Bool _) = Just Refl+    testEquality _ _ = Nothing++-- constructors only+-- import Data.GADT.Compare+-- instance GEq Cmd where+--   geq = testEquality++instance {-# OVERLAPPING #-} Eq (Some Cmd) where+  Some (Cmd_Int a) == Some (Cmd_Int b) = a == b+  Some (Cmd_Bool a) == Some (Cmd_Bool b) = a == b+  _ == _ = False++instance Arbitrary (Some Cmd) where+  arbitrary = oneof+    [ Some . Cmd_Int <$> arbitrary+    , Some . Cmd_Bool <$> arbitrary+    ]++-- | @OpCode@ @Serializer@+opcode :: MonadTrans t => Serializer t OpCode+opcode = Serializer+  { getS = lift getEnum+  , putS = lift . putEnum+  }++-- * Cmd Serializer++-- | @Cmd@ @Serializer@+cmdS+  :: forall t . ( MonadTrans t+     , Monad (t Get)+     , Monad (t PutM)+     )+  => 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)+  }++-- * Runners++-- | @runGetS@ specialized to @ExceptT e@+runG+  :: Serializer (ExceptT e) a+  -> ByteString+  -> Either (GetSerializerError e) a+runG s =+  transformGetError+  . runGetS s runExceptT++-- | @runPutS@ specialized to @ExceptT e@+runP+  :: Serializer (ExceptT e) a+  -> a+  -> Either e ByteString+runP s =+   (\(e, r) -> either Left (pure $ Right r) e)+  . runPutS s runExceptT++-- * Custom errors++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)+cmdSGetError = Serializer+  { getS = getS opcode >>= \case+      OpCode_Int -> Some . Cmd_Int <$> lift getInt8+      OpCode_Bool -> throwError MyGetError_Example+  , putS = putS cmdS+  }++-- *** getS with fail++cmdSGetFail+  :: ( MonadTrans t+     , MonadFail (t Get)+     , Monad (t PutM)+     )+  => Serializer t (Some Cmd)+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"+  }++-- * Elaborate++-- | Transformer for @Serializer@+newtype REST r e s m a = REST+  { _unREST :: ExceptT e (StateT s (ReaderT r m)) a }+  deriving+    ( Applicative+    , Functor+    , Monad+    , MonadError e+    , MonadReader r+    , MonadState s+    , MonadFail+    )++instance MonadTrans (REST r e s) where+  lift = REST . lift . lift . lift++-- | Runner for @REST@+restRunner+  :: Monad m+  => r+  -> s+  -> REST r e s m a+  -> m ((Either e a), s)+restRunner r s =+    (`runReaderT` r)+  . (`runStateT` s)+  . runExceptT+  . _unREST++runGRest+  :: Serializer (REST r e s) a+  -> r+  -> s+  -> ByteString+  -> Either (GetSerializerError e) a+runGRest serializer r s =+    transformGetError+  . second fst+  . runGetS+      serializer+      (restRunner 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)++cmdSRest+  :: Serializer (REST Bool e Int) (Some Cmd)+cmdSRest = 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+        if isTrue+        then lift (putInt8 (i - 1))+        else lift (putInt8 i)+      Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b)+  }++-- Primitives helpers++getInt :: Integral a => Get a+getInt = fromIntegral <$> getInt8++putInt :: Integral a => Putter a+putInt = putInt8 . fromIntegral++-- | Deserialize @Bool@ from integer+getBool :: Get Bool+getBool = (getInt :: Get Int8) >>= \case+  0 -> pure False+  1 -> pure True+  x -> fail $ "illegal bool value " ++ show x++-- | Serialize @Bool@ into integer+putBool :: Putter Bool+putBool True  = putInt (1 :: Int8)+putBool False = putInt (0 :: Int8)++-- | Utility toEnum version checking bounds using Bounded class+toEnumCheckBounds+  :: forall a+   . ( Bounded a+     , Enum a+     )+  => Int+  -> Either String a+toEnumCheckBounds = \case+  x | x < fromEnum (minBound @a) -> Left $ "enum out of min bound " ++ show x+  x | x > fromEnum (maxBound @a) -> Left $ "enum out of max bound " ++ show x+  x | otherwise -> Right $ toEnum x++-- | Deserialize @Enum@ to integer+getEnum+  :: ( Bounded a+     , Enum a+     )+  => Get a+getEnum =+  toEnumCheckBounds <$> getInt+  >>= either fail pure++-- | Serialize @Enum@ to integer+putEnum :: Enum a => Putter a+putEnum = putInt . fromEnum

@@ -1,309 +1,199 @@-{-# language AllowAmbiguousTypes #-}-{-# language KindSignatures      #-}-{-# language RankNTypes          #-}-{-# language ScopedTypeVariables #-}-{-# language DataKinds           #-}-{-# language RecordWildCards     #-}-{-# language LiberalTypeSynonyms #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}  module System.Nix.Store.Remote-  ( addToStore-  , addTextToStore-  , addSignatures-  , addIndirectRoot-  , addTempRoot-  , buildPaths-  , buildDerivation-  , ensurePath-  , findRoots-  , isValidPathUncached-  , queryValidPaths-  , queryAllValidPaths-  , querySubstitutablePaths-  , queryPathInfoUncached-  , queryReferrers-  , queryValidDerivers-  , queryDerivationOutputs-  , queryDerivationOutputNames-  , queryPathFromHashPart-  , queryMissing-  , optimiseStore-  , runStore-  , syncWithGC-  , verifyStore+  ( module System.Nix.Store.Types+  , module System.Nix.Store.Remote.Client+  , module System.Nix.Store.Remote.MonadStore   , module System.Nix.Store.Remote.Types-  )-where--import           Prelude                 hiding ( putText )-import qualified Data.ByteString.Lazy          as BSL+  -- * Compat+  , MonadStore+  -- * Runners+  , runStore+  , runStoreConnection+  , runStoreSocket+  -- ** Daemon+  , runDaemon+  , runDaemonConnection+  , justdoit+  ) where -import           Nix.Derivation                 ( Derivation )-import           System.Nix.Build               ( BuildMode-                                                , BuildResult-                                                )-import           System.Nix.Hash                ( NamedAlgo(..)-                                                , SomeNamedDigest(..)-                                                , BaseEncoding(NixBase32)-                                                , decodeDigestWith-                                                )-import           System.Nix.StorePath           ( StorePath-                                                , StorePathName-                                                , StorePathSet-                                                , StorePathHashPart-                                                )-import           System.Nix.StorePathMetadata   ( StorePathMetadata(..)-                                                , StorePathTrust(..)-                                                )-import           System.Nix.Internal.Base       ( encodeWith )+import Control.Monad.Catch (MonadMask)+import Control.Monad.Conc.Class (MonadConc)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Default.Class (Default(def))+import Network.Socket (Family, SockAddr(SockAddrUnix))+import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))+import System.Nix.Store.Remote.MonadStore+  ( runRemoteStoreT+  , MonadRemoteStore(..)+  , RemoteStoreT+  , RemoteStoreError(RemoteStoreError_GetAddrInfoFailed))+import System.Nix.Store.Remote.Client+import System.Nix.Store.Remote.Server (WorkerHelper, runProxyDaemon)+import System.Nix.Store.Remote.Types -import qualified Data.Binary.Put-import qualified Data.Map.Strict-import qualified Data.Set+import qualified Control.Monad.Catch+import qualified Network.Socket+-- see TODO bellow+--import qualified System.Directory +-- wip justdoit+import System.Nix.StorePath (StorePath) import qualified System.Nix.StorePath-import qualified System.Nix.Store.Remote.Parsers -import           System.Nix.Store.Remote.Binary-import           System.Nix.Store.Remote.Types-import           System.Nix.Store.Remote.Protocol-import           System.Nix.Store.Remote.Util-import           Crypto.Hash                    ( SHA256 )-import           System.Nix.Nar                 ( NarSource )--type RepairFlag = Bool-type CheckFlag = Bool-type SubstituteFlag = Bool---- | Pack `Nar` and add it to the store.-addToStore-  :: forall a-   . (NamedAlgo a)-  => StorePathName        -- ^ Name part of the newly created `StorePath`-  -> NarSource MonadStore -- ^ provide nar stream-  -> Bool                 -- ^ Add target directory recursively-  -> RepairFlag           -- ^ Only used by local store backend-  -> MonadStore StorePath-addToStore name source recursive _repair = do-  runOpArgsIO AddToStore $ \yield -> do-    yield $ toStrict $ Data.Binary.Put.runPut $ do-      putText $ System.Nix.StorePath.unStorePathName name-      putBool $ not $ System.Nix.Hash.algoName @a == "sha256" && recursive-      putBool recursive-      putText $ System.Nix.Hash.algoName @a-    source yield-  sockGetPath---- | Add text to store.------ Reference accepts repair but only uses it--- to throw error in case of remote talking to nix-daemon.-addTextToStore-  :: Text         -- ^ Name of the text-  -> Text         -- ^ Actual text to add-  -> StorePathSet -- ^ Set of `StorePath`s that the added text references-  -> RepairFlag   -- ^ Repair flag, must be `False` in case of remote backend-  -> MonadStore StorePath-addTextToStore name text references' repair = do-  when repair-    $ error "repairing is not supported when building through the Nix daemon"-  runOpArgs AddTextToStore $ do-    putText name-    putText text-    putPaths references'-  sockGetPath--addSignatures :: StorePath -> [BSL.ByteString] -> MonadStore ()-addSignatures p signatures = do-  void $ simpleOpArgs AddSignatures $ do-    putPath p-    putByteStrings signatures--addIndirectRoot :: StorePath -> MonadStore ()-addIndirectRoot pn = do-  void $ simpleOpArgs AddIndirectRoot $ putPath pn---- | Add temporary garbage collector root.------ This root is removed as soon as the client exits.-addTempRoot :: StorePath -> MonadStore ()-addTempRoot pn = do-  void $ simpleOpArgs AddTempRoot $ putPath pn---- | Build paths if they are an actual derivations.------ If derivation output paths are already valid, do nothing.-buildPaths :: StorePathSet -> BuildMode -> MonadStore ()-buildPaths ps bm = do-  void $ simpleOpArgs BuildPaths $ do-    putPaths ps-    putInt $ fromEnum bm--buildDerivation-  :: StorePath-  -> Derivation StorePath Text-  -> BuildMode-  -> MonadStore BuildResult-buildDerivation p drv buildMode = do-  runOpArgs BuildDerivation $ do-    putPath p-    putDerivation drv-    putEnum buildMode-    -- XXX: reason for this is unknown-    -- but without it protocol just hangs waiting for-    -- more data. Needs investigation.-    -- Intentionally the only warning that should pop-up.-    putInt (0 :: Integer)--  getSocketIncremental getBuildResult--ensurePath :: StorePath -> MonadStore ()-ensurePath pn = do-  void $ simpleOpArgs EnsurePath $ putPath pn---- | Find garbage collector roots.-findRoots :: MonadStore (Map BSL.ByteString StorePath)-findRoots = do-  runOp FindRoots-  sd  <- getStoreDir-  res <--    getSocketIncremental-    $ getMany-    $ (,)-      <$> (fromStrict <$> getByteStringLen)-      <*> getPath sd--  r <- catRights res-  pure $ Data.Map.Strict.fromList r- where-  catRights :: [(a, Either String b)] -> MonadStore [(a, b)]-  catRights = mapM ex--  ex :: (a, Either [Char] b) -> MonadStore (a, b)-  ex (x , Right y) = pure (x, y)-  ex (_x, Left e ) = error $ "Unable to decode root: " <> fromString e--isValidPathUncached :: StorePath -> MonadStore Bool-isValidPathUncached p = do-  simpleOpArgs IsValidPath $ putPath p---- | Query valid paths from set, optionally try to use substitutes.-queryValidPaths-  :: StorePathSet   -- ^ Set of `StorePath`s to query-  -> SubstituteFlag -- ^ Try substituting missing paths when `True`-  -> MonadStore StorePathSet-queryValidPaths ps substitute = do-  runOpArgs QueryValidPaths $ do-    putPaths ps-    putBool substitute-  sockGetPaths--queryAllValidPaths :: MonadStore StorePathSet-queryAllValidPaths = do-  runOp QueryAllValidPaths-  sockGetPaths--querySubstitutablePaths :: StorePathSet -> MonadStore StorePathSet-querySubstitutablePaths ps = do-  runOpArgs QuerySubstitutablePaths $ putPaths ps-  sockGetPaths--queryPathInfoUncached :: StorePath -> MonadStore StorePathMetadata-queryPathInfoUncached path = do-  runOpArgs QueryPathInfo $ do-    putPath path--  valid <- sockGetBool-  unless valid $ error "Path is not valid"--  deriverPath <- sockGetPathMay--  narHashText <- decodeUtf8 <$> sockGetStr-  let-    narHash =-      case-        decodeDigestWith @SHA256 NixBase32 narHashText-        of-        Left  e -> error $ fromString e-        Right x -> SomeDigest x--  references       <- sockGetPaths-  registrationTime <- sockGet getTime-  narBytes         <- Just <$> sockGetInt-  ultimate         <- sockGetBool--  _sigStrings      <- fmap bsToText <$> sockGetStrings-  caString         <- sockGetStr--  let-      -- XXX: signatures need pubkey from config-      sigs = Data.Set.empty--      contentAddressableAddress =-        case-          System.Nix.Store.Remote.Parsers.parseContentAddressableAddress caString-          of-          Left  e -> error $ fromString e-          Right x -> Just x--      trust = if ultimate then BuiltLocally else BuiltElsewhere+-- * Compat -  pure $ StorePathMetadata{..}+type MonadStore = RemoteStoreT IO -queryReferrers :: StorePath -> MonadStore StorePathSet-queryReferrers p = do-  runOpArgs QueryReferrers $ putPath p-  sockGetPaths+-- * Runners -queryValidDerivers :: StorePath -> MonadStore StorePathSet-queryValidDerivers p = do-  runOpArgs QueryValidDerivers $ putPath p-  sockGetPaths+runStore+  :: ( MonadIO m+     , MonadMask m+     )+  => RemoteStoreT m a+  -> Run m a+runStore = runStoreConnection def -queryDerivationOutputs :: StorePath -> MonadStore StorePathSet-queryDerivationOutputs p = do-  runOpArgs QueryDerivationOutputs $ putPath p-  sockGetPaths+runStoreConnection+  :: ( MonadIO m+     , MonadMask m+     )+  => StoreConnection+  -> RemoteStoreT m a+  -> Run m a+runStoreConnection sc k =+  connectionToSocket sc+  >>= \case+    Left e -> pure (Left e, mempty)+    Right (fam, sock) -> runStoreSocket fam sock k -queryDerivationOutputNames :: StorePath -> MonadStore StorePathSet-queryDerivationOutputNames p = do-  runOpArgs QueryDerivationOutputNames $ putPath p-  sockGetPaths+runStoreSocket+  :: ( MonadIO m+     , MonadMask m+     )+  => Family+  -> SockAddr+  -> RemoteStoreT m a+  -> Run m a+runStoreSocket sockFamily sockAddr code =+  Control.Monad.Catch.bracket+    (liftIO open)+    (liftIO . Network.Socket.close . hasStoreSocket)+    (\s -> runRemoteStoreT s $ greetServer >> code)+  where+    open = do+      soc <-+        Network.Socket.socket+          sockFamily+          Network.Socket.Stream+          Network.Socket.defaultProtocol+      Network.Socket.connect soc sockAddr+      pure soc -queryPathFromHashPart :: StorePathHashPart -> MonadStore StorePath-queryPathFromHashPart storePathHash = do-  runOpArgs QueryPathFromHashPart-    $ putByteStringLen-    $ encodeUtf8 (encodeWith NixBase32 $ coerce storePathHash)-  sockGetPath+justdoit :: Run IO (Bool, Bool)+justdoit = do+  runDaemonConnection runStore (pure ()) (StoreConnection_Socket "/tmp/dsock") $+    runStoreConnection (StoreConnection_Socket "/tmp/dsock")+      $ do+        a <- isValidPath pth+        b <- isValidPath pth+        pure (a, b)+  where+    pth :: StorePath+    pth =+      either (error . show) id+      $ System.Nix.StorePath.parsePathFromText+        def+        "/nix/store/yyznqbwam67cmp7zfwk0rkgmi9yqsdsm-hnix-store-core-0.8.0.0" -queryMissing-  :: StorePathSet-  -> MonadStore-      ( StorePathSet-- Paths that will be built-      , StorePathSet -- Paths that have substitutes-      , StorePathSet -- Unknown paths-      , Integer            -- Download size-      , Integer            -- Nar size?-      )-queryMissing ps = do-  runOpArgs QueryMissing $ putPaths ps+runDaemon+  :: forall m a+  . ( MonadIO m+    , MonadConc m+    )+  => WorkerHelper m+  -> m a+  -> m a+runDaemon workerHelper =+  runDaemonConnection+    workerHelper+    (pure ())+    def -  willBuild      <- sockGetPaths-  willSubstitute <- sockGetPaths-  unknown        <- sockGetPaths-  downloadSize'  <- sockGetInt-  narSize'       <- sockGetInt-  pure (willBuild, willSubstitute, unknown, downloadSize', narSize')+-- | Run an emulated nix daemon using given @StoreConnection@+-- the deamon will close when the continuation returns.+runDaemonConnection+  :: forall m a+  . ( MonadIO m+    , MonadConc m+    )+  => WorkerHelper m+  -> RemoteStoreT m ()+  -> StoreConnection+  -> m a+  -> m a+runDaemonConnection workerHelper postGreet sc k =+  connectionToSocket sc+  >>= \case+    Left e -> error $ show e+    Right (fam, sock) -> runDaemonSocket workerHelper postGreet fam sock k -optimiseStore :: MonadStore ()-optimiseStore = void $ simpleOp OptimiseStore+-- | Run an emulated nix daemon using given @StoreConnection@+-- the deamon will close when the continuation returns.+runDaemonSocket+  :: forall m a+  . ( MonadIO m+    , MonadConc m+    )+  => WorkerHelper m+  -> RemoteStoreT m ()+  -> Family+  -> SockAddr+  -> m a+  -> m a+runDaemonSocket workerHelper postGreet sockFamily sockAddr k =+  Control.Monad.Catch.bracket+    (liftIO+      $ Network.Socket.socket+          sockFamily+          Network.Socket.Stream+          Network.Socket.defaultProtocol+    )+    (\lsock -> liftIO $ Network.Socket.close lsock)+    $ \lsock -> do+    -- TODO: the: (\lsock -> liftIO $ Network.Socket.close lsock *> System.Directory.removeFile f)+    -- branch should really be (and even removeFile is currently omitted)+    -- a file lock followed by unlink *before* bind rather than after close.  If+    -- the program crashes (or loses power or something) then a stale unix+    -- socket will stick around and prevent the daemon from starting.  using a+    -- lock file instead means only one "copy" of the daemon can hold the lock,+    -- and can safely unlink the socket before binding no matter how shutdown+    -- occured. -syncWithGC :: MonadStore ()-syncWithGC = void $ simpleOp SyncWithGC+    -- set up the listening socket+    liftIO $ Network.Socket.bind lsock sockAddr+    runProxyDaemon workerHelper postGreet lsock k --- returns True on errors-verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool-verifyStore check repair = simpleOpArgs VerifyStore $ do-  putBool check-  putBool repair+connectionToSocket+  :: MonadIO m+  => StoreConnection+  -> m (Either RemoteStoreError (Family, SockAddr))+connectionToSocket (StoreConnection_Socket (StoreSocketPath f)) =+  pure $ pure+    ( Network.Socket.AF_UNIX+    , SockAddrUnix f+    )+connectionToSocket (StoreConnection_TCP StoreTCP{..}) = do+  addrInfo <- liftIO $ Network.Socket.getAddrInfo+    (Just Network.Socket.defaultHints)+    (Just storeTCPHost)+    (Just $ show storeTCPPort)+  case addrInfo of+      (sockAddr:_) ->+        pure $ pure+          ( Network.Socket.addrFamily sockAddr+          , Network.Socket.addrAddress sockAddr+          )+      _ -> pure (Left RemoteStoreError_GetAddrInfoFailed)

@@ -0,0 +1,137 @@+-- due to recent generic-arbitrary+{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module System.Nix.Store.Remote.Arbitrary where++import Data.Some (Some(Some))+import System.Nix.Arbitrary ()+import System.Nix.Store.Types (RepairMode(..))+import System.Nix.Store.Remote.Types++import Test.QuickCheck (Arbitrary(..), oneof, suchThat)+import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))++deriving via GenericArbitrary CheckMode+  instance Arbitrary CheckMode++deriving via GenericArbitrary SubstituteMode+  instance Arbitrary SubstituteMode++deriving via GenericArbitrary ProtoStoreConfig+  instance Arbitrary ProtoStoreConfig++deriving via GenericArbitrary ProtoVersion+  instance Arbitrary ProtoVersion++deriving via GenericArbitrary StoreText+  instance Arbitrary StoreText++-- * Logger++deriving via GenericArbitrary Activity+  instance Arbitrary Activity++deriving via GenericArbitrary ActivityID+  instance Arbitrary ActivityID++deriving via GenericArbitrary ActivityResult+  instance Arbitrary ActivityResult++deriving via GenericArbitrary Field+  instance Arbitrary Field++instance Arbitrary Trace where+  arbitrary = do+    -- we encode 0 position as Nothing+    tracePosition <- arbitrary `suchThat` (/= Just 0)+    traceHint <- arbitrary++    pure Trace{..}++deriving via GenericArbitrary BasicError+  instance Arbitrary BasicError++instance Arbitrary ErrorInfo where+  arbitrary = do+    errorInfoLevel <- arbitrary+    errorInfoMessage <- arbitrary+    -- we encode 0 position as Nothing+    errorInfoPosition <- arbitrary `suchThat` (/= Just 0)+    errorInfoTraces <- arbitrary++    pure ErrorInfo{..}++deriving via GenericArbitrary LoggerOpCode+  instance Arbitrary LoggerOpCode++deriving via GenericArbitrary Logger+  instance Arbitrary Logger++deriving via GenericArbitrary Verbosity+  instance Arbitrary Verbosity++-- * GC++deriving via GenericArbitrary GCAction+  instance Arbitrary GCAction++deriving via GenericArbitrary GCOptions+  instance Arbitrary GCOptions++-- * Handshake++deriving via GenericArbitrary WorkerMagic+  instance Arbitrary WorkerMagic++deriving via GenericArbitrary TrustedFlag+  instance Arbitrary TrustedFlag++-- * Worker protocol++deriving via GenericArbitrary WorkerOp+  instance Arbitrary WorkerOp++-- ** Request++instance Arbitrary (Some StoreRequest) where+  arbitrary = oneof+    [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair)+    , Some <$> (AddTextToStore <$> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair)+    , Some <$> (AddSignatures <$> arbitrary <*> arbitrary)+    , Some . AddIndirectRoot  <$> arbitrary+    , Some . AddTempRoot <$> arbitrary+    , Some <$> (BuildPaths <$> arbitrary <*> arbitrary)+    , Some <$> (BuildDerivation <$> arbitrary <*> arbitrary <*> arbitrary)+    , Some . CollectGarbage <$> arbitrary+    , Some . EnsurePath <$> arbitrary+    , pure $ Some FindRoots+    , Some . IsValidPath <$> arbitrary+    , Some . NarFromPath <$> arbitrary+    , Some <$> (QueryValidPaths <$> arbitrary <*> arbitrary)+    , pure $ Some QueryAllValidPaths+    , Some . QuerySubstitutablePaths <$> arbitrary+    , Some . QueryPathInfo <$> arbitrary+    , Some . QueryReferrers <$> arbitrary+    , Some . QueryValidDerivers <$> arbitrary+    , Some . QueryDerivationOutputs <$> arbitrary+    , Some . QueryDerivationOutputNames <$> arbitrary+    , Some . QueryPathFromHashPart <$> arbitrary+    , Some . QueryMissing <$> arbitrary+    , pure $ Some OptimiseStore+    , pure $ Some SyncWithGC+    , Some <$> (VerifyStore <$> arbitrary <*> arbitrary)+    ]++-- ** Reply++deriving via GenericArbitrary SuccessCodeReply+  instance Arbitrary SuccessCodeReply++deriving via GenericArbitrary GCResult+  instance Arbitrary GCResult++deriving via GenericArbitrary GCRoot+  instance Arbitrary GCRoot++deriving via GenericArbitrary Missing+  instance Arbitrary Missing

@@ -1,52 +0,0 @@-{-|-Description : Utilities for packing stuff-Maintainer  : srk <srk@48.io>-|-}-module System.Nix.Store.Remote.Binary where--import           Data.Binary.Get-import           Data.Binary.Put-import qualified Data.ByteString.Lazy          as BSL--putInt :: Integral a => a -> Put-putInt = putWord64le . fromIntegral--getInt :: Integral a => Get a-getInt = fromIntegral <$> getWord64le--putMany :: Foldable t => (a -> Put) -> t a -> Put-putMany printer xs = do-  putInt (length xs)-  mapM_ printer xs--getMany :: Get a -> Get [a]-getMany parser = do-  count <- getInt-  replicateM count parser---- length prefixed string packing with padding to 8 bytes-putByteStringLen :: BSL.ByteString -> Put-putByteStringLen x = do-  putInt len-  putLazyByteString x-  when (len `mod` 8 /= 0) $ pad $ 8 - (len `mod` 8)- where-  len :: Int-  len = fromIntegral $ BSL.length x-  pad count = replicateM_ count (putWord8 0)--putByteStrings :: Foldable t => t BSL.ByteString -> Put-putByteStrings = putMany putByteStringLen--getByteStringLen :: Get ByteString-getByteStringLen = do-  len <- getInt-  st  <- getLazyByteString len-  when (len `mod` 8 /= 0) $ do-    pads <- unpad $ fromIntegral $ 8 - (len `mod` 8)-    unless (all (== 0) pads) $ fail $ "No zeroes" <> show (st, len, pads)-  pure $ toStrict st-  where unpad x = replicateM x getWord8--getByteStrings :: Get [ByteString]-getByteStrings = getMany getByteStringLen

@@ -1,36 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language ScopedTypeVariables #-}-{-# language RankNTypes          #-}--module System.Nix.Store.Remote.Builders-  ( buildContentAddressableAddress-  )-where--import qualified Data.Text.Lazy              as TL-import           Crypto.Hash                    ( Digest )-import           System.Nix.StorePath           ( ContentAddressableAddress(..)-                                                )--import           Data.Text.Lazy.Builder         ( Builder )-import qualified Data.Text.Lazy.Builder      as TL--import           System.Nix.Hash---- | Marshall `ContentAddressableAddress` to `Text`--- in form suitable for remote protocol usage.-buildContentAddressableAddress :: ContentAddressableAddress -> TL.Text-buildContentAddressableAddress =-  TL.toLazyText . contentAddressableAddressBuilder--contentAddressableAddressBuilder :: ContentAddressableAddress -> Builder-contentAddressableAddressBuilder (Text digest) =-  "text:" <> digestBuilder digest-contentAddressableAddressBuilder (Fixed _narHashMode (SomeDigest (digest :: Digest hashAlgo))) =-  "fixed:"-  <> TL.fromText (System.Nix.Hash.algoName @hashAlgo)-  <> digestBuilder digest--digestBuilder :: Digest a -> Builder-digestBuilder =-  TL.fromText . encodeDigestWith NixBase32

@@ -0,0 +1,279 @@+module System.Nix.Store.Remote.Client+  ( addToStore+  , addToStoreNar+  , addTextToStore+  , addSignatures+  , addTempRoot+  , addIndirectRoot+  , buildPaths+  , buildDerivation+  , collectGarbage+  , ensurePath+  , findRoots+  , isValidPath+  , narFromPath+  , queryValidPaths+  , queryAllValidPaths+  , querySubstitutablePaths+  , queryPathInfo+  , queryReferrers+  , queryValidDerivers+  , queryDerivationOutputs+  , queryDerivationOutputNames+  , queryPathFromHashPart+  , queryMissing+  , optimiseStore+  , syncWithGC+  , verifyStore+  , module System.Nix.Store.Remote.Client.Core+  ) where++import Control.Monad (void, when)+import Control.Monad.Except (throwError)+import Data.ByteString (ByteString)+import Data.HashSet (HashSet)+import Data.Map (Map)+import Data.Set (Set)+import Data.Some (Some)+import Data.Word (Word64)++import System.Nix.Build (BuildMode, BuildResult)+import System.Nix.DerivedPath (DerivedPath)+import System.Nix.Hash (HashAlgo(..))+import System.Nix.Nar (NarSource)+import System.Nix.Signature (Signature)+import System.Nix.StorePath (StorePath, StorePathHashPart, StorePathName)+import System.Nix.StorePath.Metadata (Metadata)+import System.Nix.Store.Remote.MonadStore+import System.Nix.Store.Remote.Types.GC (GCOptions, GCResult, GCRoot)+import System.Nix.Store.Remote.Types.CheckMode (CheckMode)+import System.Nix.Store.Remote.Types.Query.Missing (Missing)+import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))+import System.Nix.Store.Remote.Types.StoreText (StoreText)+import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode)+import System.Nix.Store.Remote.Client.Core+import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))++import qualified Control.Monad.IO.Class+import qualified Data.Attoparsec.Text+import qualified Data.Text.IO+import qualified System.Nix.Derivation+import qualified System.Nix.StorePath++-- | Add `NarSource` to the store+addToStore+  :: MonadRemoteStore m+  => StorePathName        -- ^ Name part of the newly created `StorePath`+  -> NarSource IO         -- ^ Provide nar stream+  -> FileIngestionMethod  -- ^ Add target directory recursively+  -> Some HashAlgo        -- ^+  -> RepairMode           -- ^ Only used by local store backend+  -> m StorePath+addToStore name source method hashAlgo repair = do+  Control.Monad.when+    (repair == RepairMode_DoRepair)+    $ throwError RemoteStoreError_RapairNotSupportedByRemoteStore++  setNarSource source+  doReq (AddToStore name method hashAlgo repair)++addToStoreNar+  :: MonadRemoteStore m+  => StorePath+  -> Metadata StorePath+  -> RepairMode+  -> CheckMode+  -> (Word64 -> IO(Maybe ByteString))+  -> m ()+addToStoreNar path metadata repair checkSigs source = do+  setDataSource source+  void $ doReq (AddToStoreNar path metadata repair checkSigs)+  pure ()++-- | Add @StoreText@ to the store+-- Reference accepts repair but only uses it+-- to throw error in case of remote talking to nix-daemon.+addTextToStore+  :: MonadRemoteStore m+  => StoreText+  -> HashSet StorePath -- ^ Set of `StorePath`s that the added text references+  -> RepairMode        -- ^ Repair mode, must be `RepairMode_DontRepair` for remote backend+                       --   (only valid for local store)+  -> m StorePath+addTextToStore stext references repair = do+  Control.Monad.when+    (repair == RepairMode_DoRepair)+    $ throwError RemoteStoreError_RapairNotSupportedByRemoteStore++  doReq (AddTextToStore stext references repair)++-- | Add @Signature@s to a store path+addSignatures+  :: MonadRemoteStore m+  => StorePath+  -> Set Signature+  -> m ()+addSignatures p signatures = (void . doReq) (AddSignatures p signatures)++-- | Add temporary garbage collector root.+--+-- This root is removed as soon as the client exits.+addTempRoot+  :: MonadRemoteStore m+  => StorePath+  -> m ()+addTempRoot = void . doReq . AddTempRoot++-- | Add indirect garbage collector root.+addIndirectRoot+  :: MonadRemoteStore m+  => StorePath+  -> m ()+addIndirectRoot = void . doReq . AddIndirectRoot++-- | Build a derivation available at @StorePath@+buildDerivation+  :: MonadRemoteStore m+  => StorePath+  -> BuildMode+  -> m BuildResult+buildDerivation sp mode = do+  sd <- getStoreDir+  drvContents <-+    Control.Monad.IO.Class.liftIO+    $ Data.Text.IO.readFile+    $ System.Nix.StorePath.storePathToFilePath sd sp+  case Data.Attoparsec.Text.parseOnly+    (System.Nix.Derivation.parseDerivation sd) drvContents of+      Left e -> throwError $ RemoteStoreError_DerivationParse e+      Right drv -> doReq (BuildDerivation sp drv mode)++-- | Build paths if they are an actual derivations.+--+-- If derivation output paths are already valid, do nothing.+buildPaths+  :: MonadRemoteStore m+  => Set DerivedPath+  -> BuildMode+  -> m ()+buildPaths a b = (void . doReq) (BuildPaths a b)++collectGarbage+  :: MonadRemoteStore m+  => GCOptions+  -> m GCResult+collectGarbage = doReq . CollectGarbage++ensurePath+  :: MonadRemoteStore m+  => StorePath+  -> m ()+ensurePath = void . doReq . EnsurePath++-- | Find garbage collector roots.+findRoots+  :: MonadRemoteStore m+  => m (Map GCRoot StorePath)+findRoots = doReq FindRoots++isValidPath+  :: MonadRemoteStore m+  => StorePath+  -> m Bool+isValidPath = doReq . IsValidPath++-- | Download a NAR file.+narFromPath+  :: MonadRemoteStore m+  => StorePath -- ^ Path to generate a NAR for+  -> Word64 -- ^ Byte length of NAR+  -> (ByteString -> IO()) -- ^ Data sink where NAR bytes will be written+  -> m ()+narFromPath path narSize sink = do+  setDataSink sink+  setDataSinkSize narSize+  void $ doReq (NarFromPath path)++-- | Query valid paths from a set,+-- optionally try to use substitutes+queryValidPaths+  :: MonadRemoteStore m+  => HashSet StorePath+  -- ^ Set of @StorePath@s to query+  -> SubstituteMode+  -- ^ Try substituting missing paths when @SubstituteMode_DoSubstitute@+  -> m (HashSet StorePath)+queryValidPaths a b = doReq (QueryValidPaths a b)++-- | Query all valid paths+queryAllValidPaths+  :: MonadRemoteStore m+  => m (HashSet StorePath)+queryAllValidPaths = doReq QueryAllValidPaths++-- | Query a set of paths substituable from caches+querySubstitutablePaths+  :: MonadRemoteStore m+  => HashSet StorePath+  -> m (HashSet StorePath)+querySubstitutablePaths = doReq . QuerySubstitutablePaths++-- | Query path metadata+queryPathInfo+  :: MonadRemoteStore m+  => StorePath+  -> m (Maybe (Metadata StorePath))+queryPathInfo = doReq . QueryPathInfo++queryReferrers+  :: MonadRemoteStore m+  => StorePath+  -> m (HashSet StorePath)+queryReferrers = doReq . QueryReferrers++queryValidDerivers+  :: MonadRemoteStore m+  => StorePath+  -> m (HashSet StorePath)+queryValidDerivers = doReq . QueryValidDerivers++queryDerivationOutputs+  :: MonadRemoteStore m+  => StorePath+  -> m (HashSet StorePath)+queryDerivationOutputs = doReq . QueryDerivationOutputs++queryDerivationOutputNames+  :: MonadRemoteStore m+  => StorePath+  -> m (HashSet StorePathName)+queryDerivationOutputNames = doReq . QueryDerivationOutputNames++queryPathFromHashPart+  :: MonadRemoteStore m+  => StorePathHashPart+  -> m StorePath+queryPathFromHashPart = doReq . QueryPathFromHashPart++queryMissing+  :: MonadRemoteStore m+  => Set DerivedPath+  -> m Missing+queryMissing = doReq . QueryMissing++optimiseStore+  :: MonadRemoteStore m+  => m ()+optimiseStore = (void . doReq) OptimiseStore++syncWithGC+  :: MonadRemoteStore m+  => m ()+syncWithGC = (void . doReq) SyncWithGC++verifyStore+  :: MonadRemoteStore m+  => CheckMode+  -> RepairMode+  -> m Bool+verifyStore check repair = doReq (VerifyStore check repair)

@@ -0,0 +1,229 @@+module System.Nix.Store.Remote.Client.Core+  ( Run+  , greetServer+  , doReq+  ) where++import Control.Monad (unless, when)+import Control.Monad.Except (throwError)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString)+import Data.DList (DList)+import Data.Some (Some(Some))+import Data.Word (Word64)+import Network.Socket (Socket)+import System.Nix.Nar (NarSource)+import System.Nix.StorePath.Metadata (Metadata(..))+import System.Nix.Store.Remote.Logger (processOutput)+import System.Nix.Store.Remote.MonadStore+  ( MonadRemoteStore(..)+  , RemoteStoreError(..)+  )+import System.Nix.Store.Remote.Socket (sockPutS, sockGetS)+import System.Nix.Store.Remote.Serializer+  ( bool+  , int+  , mapErrorS+  , protoVersion+  , storeRequest+  , text+  , trustedFlag+  , workerMagic+  )+import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeOutput(..))+import System.Nix.Store.Remote.Types.Logger (Logger)+import System.Nix.Store.Remote.Types.NoReply (NoReply(..))+import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..))+import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))+import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..))+import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))++import qualified Data.ByteString+import qualified Network.Socket.ByteString++type Run m a = m (Either RemoteStoreError a, DList Logger)++-- | Perform @StoreRequest@+doReq+  :: forall m a+   . ( MonadIO m+     , MonadRemoteStore m+     , StoreReply a+     , Show a+     )+  => StoreRequest a+  -> m a+doReq = \case+  x -> do+    sockPutS+      (mapErrorS+        RemoteStoreError_SerializerRequest+          storeRequest+      )+      (Some x)++    case x of+      AddToStore {} -> do++        ms <- takeNarSource+        case ms of+          Just (stream :: NarSource IO) -> do+            soc <- getStoreSocket+            liftIO+              $ stream+              $ Network.Socket.ByteString.sendAll soc+          Nothing ->+            throwError+              RemoteStoreError_NoNarSourceProvided+        processOutput+        processReply++      AddToStoreNar _ meta _ _ -> do+        let narBytes = maybe 0 id $ metadataNarBytes meta+        maybeDataSource <- takeDataSource+        soc <- getStoreSocket+        case maybeDataSource of+          Nothing ->+            if narBytes == 0 then writeFramedSource (const (pure Nothing)) soc 0+            else throwError RemoteStoreError_NoDataSourceProvided+          Just dataSource -> do+            writeFramedSource dataSource soc narBytes+        processOutput+        pure NoReply++      NarFromPath _ -> do+        maybeSink <- getDataSink+        sink <- case maybeSink of+          Nothing -> throwError RemoteStoreError_NoDataSinkProvided+          Just sink -> pure sink+        clearDataSink+        maybeNarSize <- getDataSinkSize+        narSize <- case maybeNarSize of+          Nothing -> throwError RemoteStoreError_NoDataSinkSizeProvided+          Just narSize -> pure narSize+        clearDataSinkSize+        soc <- getStoreSocket+        processOutput+        copyToSink sink narSize soc+        pure NoReply++      _ -> do+        processOutput+        processReply++  where+    processReply = sockGetS+          (mapErrorS RemoteStoreError_SerializerReply+            $ getReplyS @a+          )++copyToSink+  :: forall m+   . ( MonadIO m+     , MonadRemoteStore m+     )+  => (ByteString -> IO()) --  ^ data sink+  -> Word64 -- ^ byte length to read+  -> Socket+  -> m ()+copyToSink sink remainingBytes soc =+  when (remainingBytes > 0) $ do+    let chunkSize = 16384+        bytesToRead = min chunkSize remainingBytes+    bytes <- liftIO $ Network.Socket.ByteString.recv soc (fromIntegral bytesToRead)+    liftIO $ sink bytes+    let nextRemainingBytes = remainingBytes - (fromIntegral . Data.ByteString.length) bytes+    copyToSink sink nextRemainingBytes soc++writeFramedSource+  :: forall m+   . ( MonadIO m+     , MonadRemoteStore m+     )+  => (Word64 -> IO(Maybe ByteString))+  -> Socket+  -> Word64+  -> m ()+writeFramedSource dataSource soc remainingBytes = do+  let chunkSize = 16384+  maybeBytes <- liftIO $ dataSource chunkSize+  case maybeBytes of+    Nothing -> do+      unless (remainingBytes == 0) $ throwError RemoteStoreError_DataSourceExhausted+      let eof :: Word64 = 0+      sockPutS int eof+    Just bytes -> do+      let bytesInChunk = fromIntegral $ Data.ByteString.length bytes+      when (bytesInChunk > chunkSize || bytesInChunk > remainingBytes) $ throwError RemoteStoreError_DataSourceReadTooLarge+      when (bytesInChunk == 0) $ throwError RemoteStoreError_DataSourceZeroLengthRead+      sockPutS int bytesInChunk+      liftIO+        $ Network.Socket.ByteString.sendAll soc bytes+      let nextRemainingBytes = remainingBytes - bytesInChunk+      writeFramedSource dataSource soc nextRemainingBytes++greetServer+  :: MonadRemoteStore m+  => m ClientHandshakeOutput+greetServer = do+  sockPutS+    (mapErrorS+      RemoteStoreError_SerializerHandshake+      workerMagic+    )+    WorkerMagic_One++  magic <-+    sockGetS+    $ mapErrorS+        RemoteStoreError_SerializerHandshake+        workerMagic++  unless+    (magic == WorkerMagic_Two)+    $ throwError RemoteStoreError_WorkerMagic2Mismatch++  daemonVersion <- sockGetS protoVersion++  when (daemonVersion < ProtoVersion 1 10)+    $ throwError RemoteStoreError_ClientVersionTooOld++  pv <- getProtoVersion+  sockPutS protoVersion pv++  let leastCommonVersion = min daemonVersion pv++  when (leastCommonVersion >= ProtoVersion 1 14)+    $ sockPutS int (0 :: Int) -- affinity, obsolete++  when (leastCommonVersion >= ProtoVersion 1 11) $ do+    sockPutS+      (mapErrorS RemoteStoreError_SerializerPut bool)+      False -- reserveSpace, obsolete++  daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33+    then do+      -- If we were buffering I/O, we would flush the output here.+      txtVer <-+        sockGetS+          $ mapErrorS+              RemoteStoreError_SerializerGet+              text+      pure $ Just txtVer+    else pure Nothing++  remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35+    then do+      sockGetS+        $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag+    else pure Nothing++  setProtoVersion leastCommonVersion+  processOutput++  pure ClientHandshakeOutput+    { clientHandshakeOutputNixVersion = daemonNixVersion+    , clientHandshakeOutputTrust = remoteTrustsUs+    , clientHandshakeOutputLeastCommonVersion = leastCommonVersion+    , clientHandshakeOutputServerVersion = daemonVersion+    }

@@ -1,86 +1,100 @@-{-# language RankNTypes #-}- module System.Nix.Store.Remote.Logger-  ( Logger(..)-  , Field(..)-  , processOutput-  )-where+  ( processOutput+  ) where +import Control.Monad.Except (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.Socket (sockGet8)+import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, RemoteStoreError(..), appendLog, getDataSource, getDataSink, getStoreSocket, getProtoVersion)+import System.Nix.Store.Remote.Types.Logger (Logger(..))+import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) -import           Prelude                 hiding ( Last )-import           Control.Monad.Except           ( throwError )-import           Data.Binary.Get+import qualified Control.Monad+import qualified Data.Serialize.Get+import qualified Data.Serializer+import qualified Network.Socket.ByteString -import           Network.Socket.ByteString      ( recv )+processOutput+  :: MonadRemoteStore m+  => m ()+processOutput = do+ protoVersion <- getProtoVersion+ sockGet8 >>= go . (decoder protoVersion)+ where+  decoder+    :: ProtoVersion+    -> ByteString+    -> Result (Either LoggerSError Logger)+  decoder protoVersion =+    Data.Serialize.Get.runGetPartial+      (runSerialT protoVersion $ Data.Serializer.getS logger) -import           System.Nix.Store.Remote.Binary-import           System.Nix.Store.Remote.Types-import           System.Nix.Store.Remote.Util+  go+    :: MonadRemoteStore m+    => Result (Either LoggerSError Logger)+    -> m ()+  go (Done ectrl leftover) = do+    let loop = do+          protoVersion <- getProtoVersion+          sockGet8 >>= go . (decoder protoVersion) +    Control.Monad.unless (leftover == mempty) $+      throwError+      $ RemoteStoreError_LoggerLeftovers+          (show ectrl)+          leftover -controlParser :: Get Logger-controlParser = do-  ctrl <- getInt-  case (ctrl :: Int) of-    0x6f6c6d67 -> Next          <$> getByteStringLen-    0x64617461 -> Read          <$> getInt-    0x64617416 -> Write         <$> getByteStringLen-    0x616c7473 -> pure Last-    0x63787470 -> flip Error    <$> getByteStringLen-                                <*> getInt-    0x53545254 -> StartActivity <$> getInt-                                <*> getInt-                                <*> getInt-                                <*> getByteStringLen-                                <*> getFields-                                <*> getInt-    0x53544f50 -> StopActivity  <$> getInt-    0x52534c54 -> Result        <$> getInt-                                <*> getInt-                                <*> getFields-    x          -> fail          $ "Invalid control message received:" <> show x+    case ectrl of+      Left e -> throwError $ RemoteStoreError_SerializerLogger e+      Right ctrl -> do+        case ctrl of+          -- These two terminate the logger loop+          Logger_Error e -> throwError $ RemoteStoreError_LoggerError e+          Logger_Last -> appendLog Logger_Last -processOutput :: MonadStore [Logger]-processOutput = go decoder- where-  decoder = runGetIncremental controlParser-  go :: Decoder Logger -> MonadStore [Logger]-  go (Done _leftover _consumed ctrl) = do-    case ctrl of-      e@(Error _ _) -> pure [e]-      Last          -> pure [Last]-      Read _n       -> do-        (mdata, _) <- get-        case mdata of-          Nothing   -> throwError "No data to read provided"-          Just part -> do-            -- XXX: we should check/assert part size against n of (Read n)-            sockPut $ putByteStringLen part-            clearData+          -- Read data from source+          Logger_Read size -> do+            mSource <- getDataSource+            case mSource of+              Nothing   ->+                throwError RemoteStoreError_NoDataSourceProvided+              Just source -> do+                mChunk <- liftIO $ source size+                case mChunk of+                  Nothing -> throwError RemoteStoreError_DataSourceExhausted+                  Just chunk -> do+                    sock <- getStoreSocket+                    liftIO $ Network.Socket.ByteString.sendAll sock chunk -        go decoder+            loop -      -- we should probably handle Read here as well-      x -> do-        next <- go decoder-        pure $ x : next-  go (Partial k) = do-    soc   <- asks storeSocket-    chunk <- liftIO (Just <$> recv soc 8)-    go (k chunk)+          -- Write data to sink+          Logger_Write out -> do+            mSink <- getDataSink+            case mSink of+              Nothing   ->+                throwError RemoteStoreError_NoDataSinkProvided+              Just sink -> do+                liftIO $ sink out -  go (Fail _leftover _consumed msg) = error $ fromString msg+            loop -getFields :: Get [Field]-getFields = do-  cnt <- getInt-  replicateM cnt getField+          -- Following we just append and loop+          -- but listed here explicitely for posterity+          x@(Logger_Next _) -> appendLog x >> loop+          x@(Logger_StartActivity {}) -> appendLog x >> loop+          x@(Logger_StopActivity {}) -> appendLog x >> loop+          x@(Logger_Result {}) -> appendLog x >> loop -getField :: Get Field-getField = do-  typ <- getInt-  case (typ :: Int) of-    0 -> LogInt <$> getInt-    1 -> LogStr <$> getByteStringLen-    x -> fail $ "Unknown log type: " <> show x+  go (Partial k) = do+    chunk <- sockGet8+    go (k chunk)++  go (Fail msg leftover) =+    throwError+    $ RemoteStoreError_LoggerParserFail+        msg+        leftover

@@ -0,0 +1,390 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module System.Nix.Store.Remote.MonadStore+  ( RemoteStoreState(..)+  , RemoteStoreError(..)+  , WorkerError(..)+  , WorkerException(..)+  , RemoteStoreT+  , runRemoteStoreT+  , MonadRemoteStore(..)+  ) where++import Control.Exception (SomeException)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.Except (MonadError)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (MonadReader, ask)+import Control.Monad.State.Strict (get, gets, modify)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.State.Strict (StateT, runStateT)+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import Data.ByteString (ByteString)+import Data.Default.Class (Default(def))+import Data.DList (DList)+import Data.Word (Word64)+import Network.Socket (Socket)+import System.Nix.Nar (NarSource)+import System.Nix.StorePath (HasStoreDir(..), StoreDir)+import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, ReplySError, SError)+import System.Nix.Store.Remote.Types.Logger (Logger, BasicError, ErrorInfo)+import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion)+import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..))++import qualified Data.DList++data RemoteStoreState = RemoteStoreState {+    remoteStoreStateConfig :: ProtoStoreConfig+  , remoteStoreStateLogs :: DList Logger+  , remoteStoreStateMDataSource :: Maybe (Word64 -> IO (Maybe ByteString))+  -- ^ Source for @Logger_Read@, this will be called repeatedly+  -- as the daemon requests chunks of size @Word64@.+  -- If the function returns Nothing and daemon tries to read more+  -- data an error is thrown.+  -- Used by @AddToStoreNar@ and @ImportPaths@ operations.+  , remoteStoreStateMDataSink :: Maybe (ByteString -> IO ())+  -- ^ Sink for @Logger_Write@, called repeatedly by the daemon+  -- to dump us some data. Used by @ExportPath@ operation.+  , remoteStoreStateMDataSinkSize :: Maybe Word64+  -- ^ Byte length to be written to the sink, for NarForPath+  , remoteStoreStateMNarSource :: Maybe (NarSource IO)+  }++instance HasStoreDir RemoteStoreState where+  hasStoreDir = hasStoreDir . remoteStoreStateConfig++instance HasProtoVersion RemoteStoreState where+  hasProtoVersion = hasProtoVersion . remoteStoreStateConfig++data RemoteStoreError+  = RemoteStoreError_Fixme String+  | RemoteStoreError_BuildFailed+  | RemoteStoreError_ClientVersionTooOld+  | RemoteStoreError_DerivationParse String+  | RemoteStoreError_Disconnected+  | RemoteStoreError_GetAddrInfoFailed+  | RemoteStoreError_GenericIncrementalLeftovers String ByteString -- when there are bytes left over after genericIncremental parser is done, (Done x leftover), first param is show x+  | RemoteStoreError_GenericIncrementalFail String ByteString -- when genericIncremental parser returns ((Fail msg leftover) :: Result)+  | RemoteStoreError_SerializerGet SError+  | RemoteStoreError_SerializerHandshake HandshakeSError+  | RemoteStoreError_SerializerLogger LoggerSError+  | RemoteStoreError_SerializerPut SError+  | RemoteStoreError_SerializerRequest RequestSError+  | RemoteStoreError_SerializerReply ReplySError+  | RemoteStoreError_IOException SomeException+  | RemoteStoreError_LoggerError (Either BasicError ErrorInfo)+  | RemoteStoreError_LoggerLeftovers String ByteString -- when there are bytes left over after incremental logger parser is done, (Done x leftover), first param is show x+  | RemoteStoreError_LoggerParserFail String ByteString -- when incremental parser returns ((Fail msg leftover) :: Result)+  | RemoteStoreError_NoDataSourceProvided -- remoteStoreStateMDataSource is required but it is Nothing+  | RemoteStoreError_DataSourceExhausted -- remoteStoreStateMDataSource returned Nothing but more data was requested+  | RemoteStoreError_DataSourceZeroLengthRead -- remoteStoreStateMDataSource returned a zero length ByteString+  | RemoteStoreError_DataSourceReadTooLarge -- remoteStoreStateMDataSource returned a ByteString larger than the chunk size requested or the remaining bytes+  | RemoteStoreError_NoDataSinkProvided -- remoteStoreStateMDataSink is required but it is Nothing+  | RemoteStoreError_NoDataSinkSizeProvided -- remoteStoreStateMDataSinkSize is required but it is Nothing+  | RemoteStoreError_NoNarSourceProvided+  | RemoteStoreError_OperationFailed+  | RemoteStoreError_ProtocolMismatch+  | RemoteStoreError_RapairNotSupportedByRemoteStore -- "repairing is not supported when building through the Nix daemon"+  | RemoteStoreError_WorkerMagic2Mismatch+  | RemoteStoreError_WorkerError WorkerError+  -- bad / redundant+  | RemoteStoreError_WorkerException WorkerException+  deriving Show++-- | fatal error in worker interaction which should disconnect client.+data WorkerException+  = WorkerException_ClientVersionTooOld+  | WorkerException_ProtocolMismatch+  | WorkerException_Error WorkerError+  -- ^ allowed error outside allowed worker state+--  | WorkerException_DecodingError DecodingError+--  | WorkerException_BuildFailed StorePath+  deriving (Eq, Ord, Show)++-- | Non-fatal (to server) errors in worker interaction+data WorkerError+  = WorkerError_SendClosed+  | WorkerError_InvalidOperation Word64+  | WorkerError_NotYetImplemented+  | WorkerError_UnsupportedOperation+  deriving (Eq, Ord, Show)++newtype RemoteStoreT m a = RemoteStoreT+  { _unRemoteStoreT+      :: ExceptT RemoteStoreError+          (StateT RemoteStoreState+            (ReaderT Socket m)) a+  }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadReader Socket+    --, MonadState StoreState -- Avoid making the internal state explicit+    , MonadError RemoteStoreError+    , MonadCatch+    , MonadMask+    , MonadThrow+    , MonadIO+    )++instance MonadTrans RemoteStoreT where+  lift = RemoteStoreT . lift . lift . lift++-- | Runner for @RemoteStoreT@+runRemoteStoreT+  :: Monad m+  => Socket+  -> RemoteStoreT m a+  -> m (Either RemoteStoreError a, DList Logger)+runRemoteStoreT sock =+    fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreStateLogs))+  . (`runReaderT` sock)+  . (`runStateT` emptyState)+  . runExceptT+  . _unRemoteStoreT+  where+    emptyState = RemoteStoreState+      { remoteStoreStateConfig = def+      , remoteStoreStateLogs = mempty+      , remoteStoreStateMDataSource = Nothing+      , remoteStoreStateMDataSink = Nothing+      , remoteStoreStateMDataSinkSize = Nothing+      , remoteStoreStateMNarSource = Nothing+      }++class ( MonadIO m+      , MonadError RemoteStoreError m+      )+      => MonadRemoteStore m where++  appendLog :: Logger -> m ()+  default appendLog+    :: ( MonadTrans t+       , MonadRemoteStore m'+       , m ~ t m'+       )+    => Logger+    -> m ()+  appendLog = lift . appendLog++  getConfig :: m ProtoStoreConfig+  default getConfig+    :: ( MonadTrans t+       , MonadRemoteStore m'+       , m ~ t m'+       )+    => m ProtoStoreConfig+  getConfig = lift getConfig++  getStoreDir :: m StoreDir+  default getStoreDir+    :: ( MonadTrans t+       , MonadRemoteStore m'+       , m ~ t m'+       )+    => m StoreDir+  getStoreDir = lift getStoreDir++  setStoreDir :: StoreDir -> m ()+  default setStoreDir+    :: ( MonadTrans t+       , MonadRemoteStore m'+       , m ~ t m'+       )+    => StoreDir+    -> m ()+  setStoreDir = lift . setStoreDir++  -- | Get @ProtoVersion@ from state+  getProtoVersion :: m ProtoVersion+  default getProtoVersion+    :: ( MonadTrans t+       , MonadRemoteStore m'+       , m ~ t m'+       )+    => m ProtoVersion+  getProtoVersion = lift getProtoVersion++  setProtoVersion :: ProtoVersion -> m ()+  default setProtoVersion+    :: ( MonadTrans t+       , MonadRemoteStore m'+       , m ~ t m'+       )+    => ProtoVersion+    -> m ()+  setProtoVersion = lift . setProtoVersion++  getStoreSocket :: m Socket+  default getStoreSocket+    :: ( MonadTrans t+       , MonadRemoteStore m'+       , m ~ t m'+       )+    => m Socket+  getStoreSocket = lift getStoreSocket++  setNarSource :: NarSource IO -> m ()+  default setNarSource+   :: ( MonadTrans t+      , MonadRemoteStore m'+      , m ~ t m'+      )+   => NarSource IO+   -> m ()+  setNarSource x = lift (setNarSource x)++  takeNarSource :: m (Maybe (NarSource IO))+  default takeNarSource+   :: ( MonadTrans t+      , MonadRemoteStore m'+      , m ~ t m'+      )+   => m (Maybe (NarSource IO))+  takeNarSource = lift takeNarSource++  setDataSource :: (Word64 -> IO (Maybe ByteString)) -> m ()+  default setDataSource+   :: ( MonadTrans t+      , MonadRemoteStore m'+      , m ~ t m'+      )+   => (Word64 -> IO (Maybe ByteString))+   -> m ()+  setDataSource x = lift (setDataSource x)++  takeDataSource :: m (Maybe (Word64 -> IO (Maybe ByteString)))+  default takeDataSource+   :: ( MonadTrans t+      , MonadRemoteStore m'+      , m ~ t m'+      )+   => m (Maybe (Word64 -> IO (Maybe ByteString)))+  takeDataSource = lift takeDataSource++  getDataSource :: m (Maybe (Word64 -> IO (Maybe ByteString)))+  default getDataSource+   :: ( MonadTrans t+      , MonadRemoteStore m'+      , m ~ t m'+      )+   => m (Maybe (Word64 -> IO (Maybe ByteString)))+  getDataSource = lift getDataSource++  clearDataSource :: m ()+  default clearDataSource+    :: ( MonadTrans t+       , MonadRemoteStore m'+       , m ~ t m'+       )+    => m ()+  clearDataSource = lift clearDataSource++  setDataSink :: (ByteString -> IO ()) -> m ()+  default setDataSink+   :: ( MonadTrans t+      , MonadRemoteStore m'+      , m ~ t m'+      )+   => (ByteString -> IO ())+   -> m ()+  setDataSink x = lift (setDataSink x)++  getDataSink :: m (Maybe (ByteString -> IO ()))+  default getDataSink+   :: ( MonadTrans t+      , MonadRemoteStore m'+      , m ~ t m'+      )+   => m (Maybe (ByteString -> IO ()))+  getDataSink = lift getDataSink++  clearDataSink :: m ()+  default clearDataSink+    :: ( MonadTrans t+       , MonadRemoteStore m'+       , m ~ t m'+       )+    => m ()+  clearDataSink = lift clearDataSink++  setDataSinkSize :: Word64 -> m ()+  default setDataSinkSize+   :: ( MonadTrans t+      , MonadRemoteStore m'+      , m ~ t m'+      )+   => Word64+   -> m ()+  setDataSinkSize x = lift (setDataSinkSize x)++  getDataSinkSize :: m (Maybe Word64)+  default getDataSinkSize+   :: ( MonadTrans t+      , MonadRemoteStore m'+      , m ~ t m'+      )+   => m (Maybe Word64)+  getDataSinkSize = lift getDataSinkSize++  clearDataSinkSize :: m ()+  default clearDataSinkSize+    :: ( MonadTrans t+       , MonadRemoteStore m'+       , m ~ t m'+       )+    => m ()+  clearDataSinkSize = lift clearDataSinkSize++instance MonadRemoteStore m => MonadRemoteStore (StateT s m)+instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m)+instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m)++instance MonadIO m => MonadRemoteStore (RemoteStoreT m) where++  getConfig = RemoteStoreT $ gets remoteStoreStateConfig+  getProtoVersion = RemoteStoreT $ gets hasProtoVersion+  setProtoVersion pv =+    RemoteStoreT $ modify $ \s ->+      s { remoteStoreStateConfig =+            (remoteStoreStateConfig s) { protoStoreConfigProtoVersion = pv }+      }+  getStoreDir = RemoteStoreT $ gets hasStoreDir+  setStoreDir sd =+    RemoteStoreT $ modify $ \s ->+      s { remoteStoreStateConfig =+            (remoteStoreStateConfig s) { protoStoreConfigDir = sd }+      }++  getStoreSocket = RemoteStoreT ask++  appendLog x =+    RemoteStoreT+    $ modify+    $ \s -> s { remoteStoreStateLogs = remoteStoreStateLogs s `Data.DList.snoc` x }++  setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = pure x }+  getDataSource = RemoteStoreT (gets remoteStoreStateMDataSource)+  clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = Nothing }++  takeDataSource = RemoteStoreT $ do+    x <- remoteStoreStateMDataSource <$> get+    modify $ \s -> s { remoteStoreStateMDataSource = Nothing }+    pure x++  setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSink = pure x }+  getDataSink = RemoteStoreT (gets remoteStoreStateMDataSink)+  clearDataSink = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSink = Nothing }++  setDataSinkSize x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSinkSize = pure x }+  getDataSinkSize = RemoteStoreT (gets remoteStoreStateMDataSinkSize)+  clearDataSinkSize = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSinkSize = Nothing }++  setNarSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMNarSource = pure x }+  takeNarSource = RemoteStoreT $ do+    x <- remoteStoreStateMNarSource <$> get+    modify $ \s -> s { remoteStoreStateMNarSource = Nothing }+    pure x

@@ -1,51 +0,0 @@-{-# language AllowAmbiguousTypes #-}-{-# language ScopedTypeVariables #-}-{-# language RankNTypes          #-}-{-# language DataKinds           #-}--module System.Nix.Store.Remote.Parsers-  ( parseContentAddressableAddress-  )-where--import           Data.Attoparsec.ByteString.Char8-import           System.Nix.Hash-import           System.Nix.StorePath           ( ContentAddressableAddress(..)-                                                , NarHashMode(..)-                                                )-import           Crypto.Hash                    ( SHA256 )---- | Parse `ContentAddressableAddress` from `ByteString`-parseContentAddressableAddress-  :: ByteString -> Either String ContentAddressableAddress-parseContentAddressableAddress =-  Data.Attoparsec.ByteString.Char8.parseOnly contentAddressableAddressParser---- | Parser for content addressable field-contentAddressableAddressParser :: Parser ContentAddressableAddress-contentAddressableAddressParser = caText <|> caFixed---- | Parser for @text:sha256:<h>@-caText :: Parser ContentAddressableAddress-caText = do-  _      <- "text:sha256:"-  digest <- decodeDigestWith @SHA256 NixBase32 <$> parseHash-  either fail pure $ Text <$> digest---- | Parser for @fixed:<r?>:<ht>:<h>@-caFixed :: Parser ContentAddressableAddress-caFixed = do-  _           <- "fixed:"-  narHashMode <- (Recursive <$ "r:") <|> (RegularFile <$ "")-  digest      <- parseTypedDigest-  either fail pure $ Fixed narHashMode <$> digest--parseTypedDigest :: Parser (Either String SomeNamedDigest)-parseTypedDigest = mkNamedDigest <$> parseHashType <*> parseHash--parseHashType :: Parser Text-parseHashType =-  decodeUtf8 <$> ("sha256" <|> "sha512" <|> "sha1" <|> "md5") <* (":" <|> "-")--parseHash :: Parser Text-parseHash = decodeUtf8 <$> takeWhile1 (/= ':')

@@ -1,215 +0,0 @@-{-# language DataKinds #-}-{-# language ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}-module System.Nix.Store.Remote.Protocol-  ( WorkerOp(..)-  , simpleOp-  , simpleOpArgs-  , runOp-  , runOpArgs-  , runOpArgsIO-  , runStore-  , runStoreOpts-  , runStoreOptsTCP-  , runStoreOpts'-  )-where--import qualified Relude.Unsafe                 as Unsafe--import           Control.Exception              ( bracket )-import           Control.Monad.Except--import           Data.Binary.Get-import           Data.Binary.Put-import qualified Data.ByteString-import qualified Data.ByteString.Char8--import           Network.Socket                 ( SockAddr(SockAddrUnix) )-import qualified Network.Socket                 as S-import           Network.Socket.ByteString      ( recv-                                                , sendAll-                                                )--import           System.Nix.Store.Remote.Binary-import           System.Nix.Store.Remote.Logger-import           System.Nix.Store.Remote.Types-import           System.Nix.Store.Remote.Util---protoVersion :: Int-protoVersion = 0x115--- major protoVersion & 0xFF00--- minor ..           & 0x00FF--workerMagic1 :: Int-workerMagic1 = 0x6e697863-workerMagic2 :: Int-workerMagic2 = 0x6478696f--defaultSockPath :: String-defaultSockPath = "/nix/var/nix/daemon-socket/socket"--data WorkerOp =-    IsValidPath-  | HasSubstitutes-  | QueryReferrers-  | AddToStore-  | AddTextToStore-  | BuildPaths-  | EnsurePath-  | AddTempRoot-  | AddIndirectRoot-  | SyncWithGC-  | FindRoots-  | SetOptions-  | CollectGarbage-  | QuerySubstitutablePathInfo-  | QueryDerivationOutputs-  | QueryAllValidPaths-  | QueryFailedPaths-  | ClearFailedPaths-  | QueryPathInfo-  | QueryDerivationOutputNames-  | QueryPathFromHashPart-  | QuerySubstitutablePathInfos-  | QueryValidPaths-  | QuerySubstitutablePaths-  | QueryValidDerivers-  | OptimiseStore-  | VerifyStore-  | BuildDerivation-  | AddSignatures-  | NarFromPath-  | AddToStoreNar-  | QueryMissing-  deriving (Eq, Ord, Show)--opNum :: WorkerOp -> Int-opNum IsValidPath                 = 1-opNum HasSubstitutes              = 3-opNum QueryReferrers              = 6-opNum AddToStore                  = 7-opNum AddTextToStore              = 8-opNum BuildPaths                  = 9-opNum EnsurePath                  = 10-opNum AddTempRoot                 = 11-opNum AddIndirectRoot             = 12-opNum SyncWithGC                  = 13-opNum FindRoots                   = 14-opNum SetOptions                  = 19-opNum CollectGarbage              = 20-opNum QuerySubstitutablePathInfo  = 21-opNum QueryDerivationOutputs      = 22-opNum QueryAllValidPaths          = 23-opNum QueryFailedPaths            = 24-opNum ClearFailedPaths            = 25-opNum QueryPathInfo               = 26-opNum QueryDerivationOutputNames  = 28-opNum QueryPathFromHashPart       = 29-opNum QuerySubstitutablePathInfos = 30-opNum QueryValidPaths             = 31-opNum QuerySubstitutablePaths     = 32-opNum QueryValidDerivers          = 33-opNum OptimiseStore               = 34-opNum VerifyStore                 = 35-opNum BuildDerivation             = 36-opNum AddSignatures               = 37-opNum NarFromPath                 = 38-opNum AddToStoreNar               = 39-opNum QueryMissing                = 40---simpleOp :: WorkerOp -> MonadStore Bool-simpleOp op = simpleOpArgs op pass--simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool-simpleOpArgs op args = do-  runOpArgs op args-  err <- gotError-  bool-    sockGetBool-    (do-      Error _num msg <- Unsafe.head <$> getError-      throwError $ Data.ByteString.Char8.unpack msg-    )-    err--runOp :: WorkerOp -> MonadStore ()-runOp op = runOpArgs op pass--runOpArgs :: WorkerOp -> Put -> MonadStore ()-runOpArgs op args =-  runOpArgsIO-    op-    (\encode -> encode $ toStrict $ runPut args)--runOpArgsIO-  :: WorkerOp-  -> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ())-  -> MonadStore ()-runOpArgsIO op encoder = do--  sockPut $ putInt $ opNum op--  soc <- asks storeSocket-  encoder (liftIO . sendAll soc)--  out <- processOutput-  modify (\(a, b) -> (a, b <> out))-  err <- gotError-  when err $ do-    Error _num msg <- Unsafe.head <$> getError-    throwError $ Data.ByteString.Char8.unpack msg--runStore :: MonadStore a -> IO (Either String a, [Logger])-runStore = runStoreOpts defaultSockPath "/nix/store"--runStoreOpts-  :: FilePath -> FilePath -> MonadStore a -> IO (Either String a, [Logger])-runStoreOpts path = runStoreOpts' S.AF_UNIX (SockAddrUnix path)--runStoreOptsTCP-  :: String -> Int -> FilePath -> MonadStore a -> IO (Either String a, [Logger])-runStoreOptsTCP host port storeRootDir code = do-  S.getAddrInfo (Just S.defaultHints) (Just host) (Just $ show port) >>= \case-    (sockAddr:_) -> runStoreOpts' (S.addrFamily sockAddr) (S.addrAddress sockAddr) storeRootDir code-    _ -> pure (Left "Couldn't resolve host and port with getAddrInfo.", [])--runStoreOpts'-  :: S.Family -> S.SockAddr -> FilePath -> MonadStore a -> IO (Either String a, [Logger])-runStoreOpts' sockFamily sockAddr storeRootDir code =-  bracket open (S.close . storeSocket) run-- where-  open = do-    soc <- S.socket sockFamily S.Stream 0-    S.connect soc sockAddr-    pure StoreConfig-        { storeSocket = soc-        , storeDir = storeRootDir-        }--  greet = do-    sockPut $ putInt workerMagic1-    soc      <- asks storeSocket-    vermagic <- liftIO $ recv soc 16-    let-      (magic2, _daemonProtoVersion) =-        flip runGet (fromStrict vermagic)-          $ (,)-            <$> (getInt :: Get Int)-            <*> (getInt :: Get Int)-    unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch"--    sockPut $ putInt protoVersion -- clientVersion-    sockPut $ putInt (0 :: Int)   -- affinity-    sockPut $ putInt (0 :: Int)   -- obsolete reserveSpace--    processOutput--  run sock =-    fmap (\(res, (_data, logs)) -> (res, logs))-      $ (`runReaderT` sock)-      $ (`runStateT` (Nothing, []))-      $ runExceptT (greet >> code)

@@ -0,0 +1,1567 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-|+Description : NixSerializer+Copyright   : (c) John Ericson, 2023+                  Sorki, 2023+|-}++module System.Nix.Store.Remote.Serializer+  (+  -- * NixSerializer+    NixSerializer+  , mapReaderS+  , mapErrorS+  -- * Errors+  , SError(..)+  -- ** Runners+  , runSerialT+  , runG+  , runP+  -- * Primitives+  , int+  , bool+  , byteString+  , enum+  , text+  , maybeText+  -- * UTCTime+  , time+  -- * Combinators+  , list+  , set+  , hashSet+  , mapS+  , vector+  , json+  -- * ProtoVersion+  , protoVersion+  -- * StorePath+  , storePath+  , maybePath+  , storePathHashPart+  , storePathName+  -- * Metadata+  , pathMetadata+  -- * OutputName+  , outputName+  -- * Signatures+  , signature+  , narSignature+  -- * Some HashAlgo+  , someHashAlgo+  -- * Digest+  , digest+  -- * DSum HashAlgo Digest+  , namedDigest+  -- * Derivation+  , derivation+  -- * Derivation+  , derivedPath+  -- * Build+  , buildMode+  -- * Logger+  , LoggerSError(..)+  , activityID+  , maybeActivity+  , activity+  , activityResult+  , field+  , trace+  , basicError+  , errorInfo+  , loggerOpCode+  , logger+  , verbosity+  -- * Handshake+  , HandshakeSError(..)+  , workerMagic+  , trustedFlag+  -- * Worker protocol+  , storeText+  , workerOp+  -- ** Request+  , RequestSError(..)+  , storeRequest+  -- ** Reply+  , ReplySError(..)+  , opSuccess+  , noop+  -- *** Realisation+  , derivationOutputTyped+  , realisation+  , realisationWithId+  -- *** BuildResult+  , buildResult+  -- *** GCResult+  , gcResult+  -- *** GCResult+  , gcRoot+  -- *** Missing+  , missing+  -- *** Maybe (Metadata StorePath)+  , maybePathMetadata+  ) where++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 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(..))+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 (DerivationOutputError, Realisation(..), RealisationWithId(..))+import System.Nix.Signature (Signature, NarSignature)+import System.Nix.Store.Types (FileIngestionMethod(..), 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 qualified Control.Monad+import qualified Control.Monad.Reader+import qualified Data.Aeson+import qualified Data.Attoparsec.Text+import qualified Data.Bifunctor+import qualified Data.Bits+import qualified Data.ByteString+import qualified Data.ByteString.Char8+import qualified Data.ByteString.Lazy+import qualified Data.Coerce+import qualified Data.HashSet+import qualified Data.Map.Strict+import qualified Data.Maybe+import qualified Data.Serialize.Get+import qualified Data.Serialize.Put+import qualified Data.Set+import qualified Data.Some+import qualified Data.Text+import qualified Data.Text.Encoding+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Builder+import qualified Data.Time.Clock.POSIX+import qualified Data.Vector+import qualified System.Nix.Base+import qualified System.Nix.ContentAddress+import qualified System.Nix.DerivedPath+import qualified System.Nix.Hash+import qualified System.Nix.OutputName+import qualified System.Nix.Realisation+import qualified System.Nix.Signature+import qualified System.Nix.StorePath++-- | Transformer for @Serializer@+newtype SerialT r e m a = SerialT+  { _unSerialT :: ExceptT e (ReaderT r m) a }+  deriving+    ( Applicative+    , Functor+    , Monad+    , MonadError e+    , MonadReader r+    , MonadFail+    )++instance MonadTrans (SerialT r e) where+  lift = SerialT . lift . lift++-- | Runner for @SerialT@+runSerialT+  :: Monad m+  => r+  -> SerialT r e m a+  -> m (Either e a)+runSerialT r =+    (`runReaderT` r)+  . runExceptT+  . _unSerialT++mapErrorST+  :: Functor m+  => (e -> e')+  -> SerialT r e m a+  -> SerialT r e' m a+mapErrorST f =+    SerialT+    . withExceptT f+    . _unSerialT++mapErrorS+  :: (e -> e')+  -> NixSerializer r e a+  -> NixSerializer r e' a+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+  }++-- * NixSerializer++type NixSerializer r e = Serializer (SerialT r e)++-- * Errors++data SError+  = SError+  | SError_BadPadding+      { badPaddingStr :: ByteString+      , badPaddingLen :: Int+      , badPaddingPads :: [Word8]+      }+  | SError_ContentAddress String+  | SError_DerivedPath ParseOutputsError+  | SError_DerivationOutput DerivationOutputError+  | SError_Digest String+  | SError_EnumOutOfMinBound Int+  | SError_EnumOutOfMaxBound Int+  | SError_HashAlgo String+  | SError_IllegalBool Word64+  | SError_InvalidNixBase32+  | SError_JSONDecoding String+  | SError_NarHashMustBeSHA256+  | SError_NotYetImplemented String (ForPV ProtoVersion)+  | SError_Name InvalidNameError+  | SError_Path InvalidPathError+  | SError_Signature String+  deriving (Eq, Ord, Generic, Show)++data ForPV a+  = ForPV_Newer a+  | ForPV_Older a+  deriving (Eq, Ord, Generic, Show)++-- ** Runners++runG+  :: NixSerializer r e a+  -> r+  -> ByteString+  -> Either (GetSerializerError e) a+runG serializer r =+    transformGetError+  . runGetS+      serializer+      (runSerialT r)++runP+  :: NixSerializer r e a+  -> r+  -> a+  -> Either e ByteString+runP serializer r =+    transformPutError+  . runPutS+      serializer+      (runSerialT r)++-- * Primitives++int :: Integral a => NixSerializer r e a+int = Serializer+  { getS = fromIntegral <$> lift Data.Serialize.Get.getWord64le+  , putS = lift . Data.Serialize.Put.putWord64le . fromIntegral+  }++bool :: NixSerializer r SError Bool+bool = Serializer+  { getS = getS (int @Word64) >>= \case+      0 -> pure False+      1 -> pure True+      x -> throwError $ SError_IllegalBool x+  , putS = \case+      False -> putS (int @Word8) 0+      True  -> putS (int @Word8) 1+  }++byteString :: NixSerializer r SError ByteString+byteString = Serializer+  { getS = do+      len <- getS int+      st  <- lift $ Data.Serialize.Get.getByteString len+      Control.Monad.when (len `mod` 8 /= 0) $ do+        pads <- unpad $ fromIntegral $ 8 - (len `mod` 8)+        Control.Monad.unless+          (all (== 0) pads)+          $ throwError+          $ SError_BadPadding st len pads+      pure st+  , putS = \x -> do+      let len = Data.ByteString.length x+      putS int len+      lift $ Data.Serialize.Put.putByteString x+      Control.Monad.when+        (len `mod` 8 /= 0)+        $ pad $ 8 - (len `mod` 8)+  }+  where+    unpad count =+      Control.Monad.replicateM+        count+        (lift Data.Serialize.Get.getWord8)+    pad count =+      Control.Monad.replicateM_+        count+        (lift $ Data.Serialize.Put.putWord8 0)++-- | Utility toEnum version checking bounds using Bounded class+toEnumCheckBoundsM+  :: forall a m+   . ( Bounded a+     , Enum a+     , MonadError SError m+     )+  => Int+  -> m a+toEnumCheckBoundsM = \case+  x | x < fromEnum (minBound @a) -> throwError $ SError_EnumOutOfMinBound x+  x | x > fromEnum (maxBound @a) -> throwError $ SError_EnumOutOfMaxBound x+  x | otherwise -> pure $ toEnum x++enum+  :: ( Bounded a+     , Enum a+     )+  => NixSerializer r SError a+enum = Serializer+  { getS = getS int >>= toEnumCheckBoundsM+  , putS = putS int . fromEnum+  }++text :: NixSerializer r SError Text+text = mapIsoSerializer+  Data.Text.Encoding.decodeUtf8+  Data.Text.Encoding.encodeUtf8+  byteString++-- TODO Parser Builder+_textBuilder :: NixSerializer r 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 = mapIsoSerializer+  (\case+    t | Data.Text.null t -> Nothing+    t | otherwise -> Just t+  )+  (Data.Maybe.fromMaybe mempty)+  text++-- * UTCTime++time :: NixSerializer r e UTCTime+time = Serializer+  { getS =+      Data.Time.Clock.POSIX.posixSecondsToUTCTime+      . toPicoSeconds+      <$> getS int+  , putS =+      putS int+      . fromPicoSeconds+      . Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds+  }+  where+    -- fancy (*10^12), from Int to Uni to Pico(seconds)+    toPicoSeconds :: Int -> NominalDiffTime+    toPicoSeconds n = realToFrac (toEnum n :: Uni)++    -- fancy (`div`10^12), from Pico to Uni to Int+    fromPicoSeconds :: NominalDiffTime -> Int+    fromPicoSeconds = (fromEnum :: Uni -> Int) . realToFrac++-- * Combinators++list+  :: NixSerializer r e a+  -> NixSerializer r e [a]+list s = Serializer+  { getS = do+      count <- getS int+      Control.Monad.replicateM count (getS s)+  , putS = \xs -> do+      putS int (length xs)+      mapM_ (putS s) xs+  }++set+  :: Ord a+  => NixSerializer r e a+  -> NixSerializer r e (Set a)+set =+  mapIsoSerializer+    Data.Set.fromList+    Data.Set.toList+  . list++hashSet+  :: ( Eq a+     , Hashable a+     )+  => NixSerializer r e a+  -> NixSerializer r e (HashSet a)+hashSet =+  mapIsoSerializer+    Data.HashSet.fromList+    Data.HashSet.toList+  . list++mapS+  :: Ord k+  => NixSerializer r e k+  -> NixSerializer r e v+  -> NixSerializer r e (Map k v)+mapS k v =+  mapIsoSerializer+    Data.Map.Strict.fromList+    Data.Map.Strict.toList+  $ list+  $ tup k v++vector+  :: Ord a+  => NixSerializer r e a+  -> NixSerializer r e (Vector a)+vector =+  mapIsoSerializer+    Data.Vector.fromList+    Data.Vector.toList+  . list++json+  :: ( FromJSON a+     , ToJSON a+     )+  => NixSerializer r SError a+json =+  mapPrismSerializer+    ( Data.Bifunctor.first SError_JSONDecoding+      . Data.Aeson.eitherDecode+    )+    Data.Aeson.encode+    $ mapIsoSerializer+        Data.ByteString.Lazy.fromStrict+        Data.ByteString.Lazy.toStrict+        byteString++-- * ProtoVersion++-- protoVersion_major & 0xFF00+-- protoVersion_minor & 0x00FF+protoVersion :: NixSerializer r e ProtoVersion+protoVersion = Serializer+  { getS = do+      v <- getS (int @Word32)+      pure ProtoVersion+        { protoVersion_major = fromIntegral $ Data.Bits.shiftR v 8+        , protoVersion_minor = fromIntegral $ v Data.Bits..&. 0x00FF+        }+  , putS = \p ->+      putS (int @Word32)+      $ ((Data.Bits.shiftL (fromIntegral $ protoVersion_major p :: Word32) 8)+          Data.Bits..|. fromIntegral (protoVersion_minor p))+  }++-- * 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+  }++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++  , 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 =+  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)+        text++storePathName :: NixSerializer r SError StorePathName+storePathName =+  mapPrismSerializer+    (Data.Bifunctor.first SError_Name+     . System.Nix.StorePath.mkStorePathName)+    System.Nix.StorePath.unStorePathName+    text++pathMetadata+  :: HasStoreDir r+  => NixSerializer r SError (Metadata StorePath)+pathMetadata = Serializer+  { getS = do+      metadataDeriverPath <- getS maybePath++      digest' <- getS $ digest Base16+      let metadataNarHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest'++      metadataReferences <- getS $ hashSet storePath+      metadataRegistrationTime <- getS time+      metadataNarBytes <-+        (\case+          0 -> Nothing+          size -> Just size+        ) <$> getS int+      metadataTrust <- getS storePathTrust++      metadataSigs <- getS $ set narSignature+      metadataContentAddress <- getS maybeContentAddress++      pure $ Metadata{..}++  , putS = \Metadata{..} -> do+      putS maybePath metadataDeriverPath++      let putNarHash+            :: DSum HashAlgo Digest+            -> SerialT r SError PutM ()+          putNarHash = \case+            System.Nix.Hash.HashAlgo_SHA256 :=> d+              -> putS (digest @SHA256 Base16) d+            _ -> throwError SError_NarHashMustBeSHA256++      putNarHash metadataNarHash++      putS (hashSet storePath) metadataReferences+      putS time metadataRegistrationTime+      putS int $ Data.Maybe.fromMaybe 0 metadataNarBytes+      putS storePathTrust metadataTrust+      putS (set narSignature) metadataSigs+      putS maybeContentAddress metadataContentAddress+  }+  where+    maybeContentAddress+      :: NixSerializer r SError (Maybe ContentAddress)+    maybeContentAddress =+      mapPrismSerializer+        (maybe+          (pure Nothing)+           $ Data.Bifunctor.bimap+               SError_ContentAddress+               Just+           . System.Nix.ContentAddress.parseContentAddress+        )+        (fmap System.Nix.ContentAddress.buildContentAddress)+        maybeText++    storePathTrust+      :: NixSerializer r SError StorePathTrust+    storePathTrust =+      mapIsoSerializer+        (\case False -> BuiltElsewhere; True -> BuiltLocally)+        (\case BuiltElsewhere -> False; BuiltLocally -> True)+        bool++-- * OutputName++outputName :: NixSerializer r SError OutputName+outputName =+  mapPrismSerializer+    (Data.Bifunctor.first SError_Name+     . System.Nix.OutputName.mkOutputName)+    System.Nix.OutputName.unOutputName+    text++-- * Signatures++signature+  :: NixSerializer r SError Signature+signature =+  mapPrismSerializer+    (Data.Bifunctor.first SError_Signature+     . Data.Attoparsec.Text.parseOnly+         System.Nix.Signature.signatureParser)+    (System.Nix.Signature.signatureToText)+    text++narSignature+  :: NixSerializer r SError NarSignature+narSignature =+  mapPrismSerializer+    (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 =+  mapPrismSerializer+    (Data.Bifunctor.first SError_HashAlgo+     . System.Nix.Hash.textToAlgo)+    (Data.Some.foldSome System.Nix.Hash.algoToText)+    text++-- * Digest++digest+  :: forall a r+   . 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++-- * DSum HashAlgo Digest++namedDigest :: NixSerializer r SError (DSum HashAlgo Digest)+namedDigest = Serializer+  { getS = do+      sriHash <- getS text+      let (sriName, _h) = Data.Text.breakOn (Data.Text.singleton '-') sriHash+      -- bit hacky since mkNamedDigest does the check+      -- that the expected matches but we don't know+      -- what we expect here (i.e. handle each HashAlgo)+      case System.Nix.Hash.mkNamedDigest sriName sriHash of+        Left e -> throwError $ SError_Digest e+        Right x -> pure x+  -- TODO: we also lack a builder for SRI hashes+  -- , putS = putS textBuilder . System.Nix.Hash.algoDigestBuilder+  , putS = \(algo :=> d) -> do+      putS text+        $  System.Nix.Hash.algoToText algo+        <> (Data.Text.singleton '-')+        <> System.Nix.Hash.encodeDigestWith NixBase32 d+  }++derivationOutput+  :: HasStoreDir r+  => NixSerializer r SError (DerivationOutput StorePath Text)+derivationOutput = 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+  }++-- * Derivation++derivation+  :: HasStoreDir r+  => NixSerializer r SError (Derivation StorePath Text)+derivation = 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+  }++-- * DerivedPath++derivedPathNew+  :: HasStoreDir r+  => NixSerializer r SError DerivedPath+derivedPathNew = Serializer+  { getS = do+      root <- Control.Monad.Reader.asks hasStoreDir+      p <- getS text+      case System.Nix.DerivedPath.parseDerivedPath root 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)+  }++derivedPath+  :: ( HasProtoVersion r+     , HasStoreDir r+     )+  => NixSerializer r SError DerivedPath+derivedPath = Serializer+  { getS = do+      pv <- Control.Monad.Reader.asks hasProtoVersion+      if pv < ProtoVersion 1 30+        then DerivedPath_Opaque <$> getS storePath+        else getS derivedPathNew+  , putS = \d -> do+      pv <- Control.Monad.Reader.asks hasProtoVersion+      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+  }++-- * Build++buildMode :: NixSerializer r SError BuildMode+buildMode = enum++-- * Logger++data LoggerSError+  = LoggerSError_Prim SError+  | LoggerSError_InvalidOpCode Word64+  | LoggerSError_TooOldForErrorInfo+  | LoggerSError_TooNewForBasicError+  | LoggerSError_UnknownLogFieldType Word8+  deriving (Eq, Ord, Generic, Show)++mapPrimE+  :: Functor m+  => SerialT r SError m a+  -> SerialT r LoggerSError m a+mapPrimE = mapErrorST LoggerSError_Prim++maybeActivity :: NixSerializer r LoggerSError (Maybe Activity)+maybeActivity = Serializer+  { getS = getS (int @Int) >>= \case+      0 -> pure Nothing+      x -> mapPrimE $ toEnumCheckBoundsM (x - 100) >>= pure . Just+  , putS = \case+      Nothing -> putS (int @Int) 0+      Just act -> putS activity act+  }++activity :: NixSerializer r LoggerSError Activity+activity = Serializer+  { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100))+  , putS = putS int . (+100) . fromEnum+  }++activityID :: NixSerializer r LoggerSError ActivityID+activityID = mapIsoSerializer ActivityID unActivityID int++activityResult :: NixSerializer r LoggerSError ActivityResult+activityResult = Serializer+  { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100))+  , putS = putS int . (+100) . fromEnum+  }++field :: NixSerializer r LoggerSError Field+field = Serializer+  { getS = getS (int @Word8) >>= \case+      0 -> Field_LogInt <$> getS int+      1 -> Field_LogStr <$> mapPrimE (getS text)+      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)+  }++trace :: NixSerializer r LoggerSError Trace+trace = Serializer+  { getS = do+      tracePosition <- (\case 0 -> Nothing; x -> Just x) <$> getS (int @Int)+      traceHint <- mapPrimE $ getS text+      pure Trace{..}+  , putS = \Trace{..} -> do+      putS int $ Data.Maybe.fromMaybe 0 tracePosition+      mapPrimE $ putS text traceHint+  }++basicError :: NixSerializer r LoggerSError BasicError+basicError = Serializer+  { getS = do+      basicErrorMessage <- mapPrimE $ getS text+      basicErrorExitStatus <- getS int+      pure BasicError{..}++  , putS = \BasicError{..} -> do+      mapPrimE $ putS text basicErrorMessage+      putS int basicErrorExitStatus+  }++errorInfo :: NixSerializer r LoggerSError ErrorInfo+errorInfo = Serializer+  { getS = do+      etyp <- mapPrimE $ getS text+      Control.Monad.unless (etyp == Data.Text.pack "Error")+        $ fail+        $ "get ErrorInfo: received unknown error type" ++ show etyp+      errorInfoLevel <- getS verbosity+      _name <- mapPrimE $ getS text -- removed error name+      errorInfoMessage <- mapPrimE $ getS text+      errorInfoPosition <- (\case 0 -> Nothing; x -> Just x) <$> getS int+      errorInfoTraces <- getS (list trace)+      pure ErrorInfo{..}++  , putS = \ErrorInfo{..} -> do+      mapPrimE $ do+        putS text $ Data.Text.pack "Error"+      putS verbosity errorInfoLevel+      mapPrimE $ 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 = Serializer+  { getS = do+      c <- getS int+      either+        (pure $ throwError (LoggerSError_InvalidOpCode c))+        pure+        $ word64ToLoggerOpCode c+  , putS = putS int . loggerOpCodeToWord64+  }++logger+  :: HasProtoVersion r+  => NixSerializer r LoggerSError Logger+logger = Serializer+  { getS = getS loggerOpCode >>= \case+      LoggerOpCode_Next ->+        mapPrimE $+          Logger_Next <$> getS text++      LoggerOpCode_Read ->+        Logger_Read <$> getS int++      LoggerOpCode_Write ->+        mapPrimE $+          Logger_Write <$> getS byteString++      LoggerOpCode_Last ->+        pure Logger_Last++      LoggerOpCode_Error -> do+        pv <- Control.Monad.Reader.asks hasProtoVersion+        Logger_Error <$>+          if protoVersion_minor pv >= 26+          then Right <$> getS errorInfo+          else Left <$> getS basicError++      LoggerOpCode_StartActivity -> do+        startActivityID <- getS activityID+        startActivityVerbosity <- getS verbosity+        startActivityType <- getS maybeActivity+        startActivityString <- mapPrimE $ getS byteString+        startActivityFields <- getS (list field)+        startActivityParentID <- getS activityID+        pure Logger_StartActivity{..}++      LoggerOpCode_StopActivity -> do+        stopActivityID <- getS activityID+        pure Logger_StopActivity{..}++      LoggerOpCode_Result -> do+        resultActivityID <- getS activityID+        resultType <- getS activityResult+        resultFields <- getS (list field)+        pure Logger_Result {..}++    , putS = \case+        Logger_Next s -> do+          putS loggerOpCode LoggerOpCode_Next+          mapPrimE $ putS text s++        Logger_Read i -> do+          putS loggerOpCode LoggerOpCode_Read+          putS int i++        Logger_Write s -> do+          putS loggerOpCode LoggerOpCode_Write+          mapPrimE $ putS byteString s++        Logger_Last ->+          putS loggerOpCode LoggerOpCode_Last++        Logger_Error basicOrInfo -> do+          putS loggerOpCode LoggerOpCode_Error++          minor <- protoVersion_minor <$> Control.Monad.Reader.asks hasProtoVersion++          case basicOrInfo of+            Left _ | minor >= 26 -> throwError $ LoggerSError_TooNewForBasicError+            Left e | otherwise -> putS basicError e+            Right _ | minor < 26 -> throwError $ LoggerSError_TooOldForErrorInfo+            Right e -> putS errorInfo e++        Logger_StartActivity{..} -> do+          putS loggerOpCode LoggerOpCode_StartActivity+          putS activityID startActivityID+          putS verbosity startActivityVerbosity+          putS maybeActivity startActivityType+          mapPrimE $+            putS byteString startActivityString+          putS (list field) startActivityFields+          putS activityID startActivityParentID++        Logger_StopActivity{..} -> do+          putS loggerOpCode LoggerOpCode_StopActivity+          putS activityID stopActivityID++        Logger_Result{..} -> do+          putS loggerOpCode LoggerOpCode_Result+          putS activityID resultActivityID+          putS activityResult resultType+          putS (list field) resultFields+  }++verbosity :: NixSerializer r LoggerSError Verbosity+verbosity = Serializer+  { getS = mapPrimE $ getS enum+  , putS = mapPrimE . putS enum+  }++-- * Handshake++data HandshakeSError+  = HandshakeSError_InvalidWorkerMagic Word64+  | HandshakeSError_InvalidTrustedFlag Word8+  deriving (Eq, Ord, Generic, Show)++workerMagic :: NixSerializer r HandshakeSError WorkerMagic+workerMagic = Serializer+  { getS = do+      c <- getS int+      either+        (pure $ throwError (HandshakeSError_InvalidWorkerMagic c))+        pure+        $ word64ToWorkerMagic c+  , putS = putS int . workerMagicToWord64+  }++trustedFlag :: NixSerializer r HandshakeSError (Maybe TrustedFlag)+trustedFlag = Serializer+  { getS = do+      n :: Word8 <- getS int+      case n of+        0 -> return $ Nothing+        1 -> return $ Just TrustedFlag_Trusted+        2 -> return $ Just TrustedFlag_NotTrusted+        _ -> throwError (HandshakeSError_InvalidTrustedFlag n)+  , putS = \n -> putS int $ case n of+      Nothing -> 0 :: Word8+      Just TrustedFlag_Trusted -> 1+      Just TrustedFlag_NotTrusted -> 2+  }++-- * Worker protocol++storeText :: NixSerializer r SError StoreText+storeText = Serializer+  { getS = do+      storeTextName <- getS storePathName+      storeTextText <- getS text+      pure StoreText{..}+  , putS = \StoreText{..} -> do+      putS storePathName storeTextName+      putS text storeTextText+  }++workerOp :: NixSerializer r SError WorkerOp+workerOp = enum++-- * Request++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+      WorkerOp_AddToStore -> mapGetE $ do+        pathName <- getS storePathName+        _fixed <- getS bool -- obsolete+        recursive <- getS enum+        hashAlgo <- getS someHashAlgo++        -- not supported by ProtoVersion < 1.25+        let repair = RepairMode_DontRepair++        pure $ Some (AddToStore pathName recursive hashAlgo repair)++      WorkerOp_AddToStoreNar -> mapGetE $ do+        storePath' <- getS storePath+        metadata <- getS pathMetadata+        repair <- getS bool+        let repairMode = if repair then RepairMode_DoRepair else RepairMode_DontRepair+        dontCheckSigs <- getS bool+        let checkSigs = if dontCheckSigs then CheckMode_DontCheck else CheckMode_DoCheck++        pure $ Some (AddToStoreNar storePath' metadata repairMode checkSigs)++      WorkerOp_AddTextToStore -> mapGetE $ do+        txt <- getS storeText+        paths <- getS (hashSet storePath)+        let repair = RepairMode_DontRepair+        pure $ Some (AddTextToStore txt paths repair)++      WorkerOp_AddSignatures -> mapGetE $ do+        path <- getS storePath+        signatures <- getS (set signature)+        pure $ Some (AddSignatures path signatures)++      WorkerOp_AddIndirectRoot -> mapGetE $ do+        Some . AddIndirectRoot <$> getS storePath++      WorkerOp_AddTempRoot -> mapGetE $ do+        Some . AddTempRoot <$> getS storePath++      WorkerOp_BuildPaths -> mapGetE $ do+        derived <- getS (set derivedPath)+        buildMode' <- getS buildMode+        pure $ Some (BuildPaths derived buildMode')++      WorkerOp_BuildDerivation -> mapGetE $ do+        path <- getS storePath+        drv <- getS derivation+        buildMode' <- getS buildMode+        pure $ Some (BuildDerivation path drv buildMode')++      WorkerOp_CollectGarbage -> mapGetE $ do+        gcOptionsOperation <- getS enum+        gcOptionsPathsToDelete <- getS (hashSet storePath)+        gcOptionsIgnoreLiveness <- getS bool+        gcOptionsMaxFreed <- getS int+        -- obsolete fields+        Control.Monad.forM_ [0..(2 :: Word8)]+          $ pure $ getS (int @Word8)+        pure $ Some (CollectGarbage GCOptions{..})++      WorkerOp_EnsurePath -> mapGetE $ do+        Some . EnsurePath <$> getS storePath++      WorkerOp_FindRoots -> mapGetE $ do+        pure $ Some FindRoots++      WorkerOp_IsValidPath -> mapGetE $ do+        Some . IsValidPath <$> getS storePath++      WorkerOp_NarFromPath -> mapGetE $ do+        Some . NarFromPath <$> getS storePath++      WorkerOp_QueryValidPaths -> mapGetE $ do+        paths <- getS (hashSet storePath)+        substituteMode <- getS enum+        pure $ Some (QueryValidPaths paths substituteMode)++      WorkerOp_QueryAllValidPaths -> mapGetE $ do+        pure $ Some QueryAllValidPaths++      WorkerOp_QuerySubstitutablePaths -> mapGetE $ do+        Some . QuerySubstitutablePaths <$> getS (hashSet storePath)++      WorkerOp_QueryPathInfo -> mapGetE $ do+        Some . QueryPathInfo <$> getS storePath++      WorkerOp_QueryReferrers -> mapGetE $ do+        Some . QueryReferrers <$> getS storePath++      WorkerOp_QueryValidDerivers -> mapGetE $ do+        Some . QueryValidDerivers <$> getS storePath++      WorkerOp_QueryDerivationOutputs -> mapGetE $ do+        Some . QueryDerivationOutputs <$> getS storePath++      WorkerOp_QueryDerivationOutputNames -> mapGetE $ do+        Some . QueryDerivationOutputNames <$> getS storePath++      WorkerOp_QueryPathFromHashPart -> mapGetE $ do+        Some . QueryPathFromHashPart <$> getS storePathHashPart++      WorkerOp_QueryMissing -> mapGetE $ do+        Some . QueryMissing <$> getS (set derivedPath)++      WorkerOp_OptimiseStore -> mapGetE $ do+        pure $ Some OptimiseStore++      WorkerOp_SyncWithGC -> mapGetE $ do+        pure $ Some SyncWithGC++      WorkerOp_VerifyStore -> mapGetE $ do+        checkMode <- getS enum+        repairMode <- getS enum++        pure $ Some (VerifyStore checkMode repairMode)++      w@WorkerOp_Reserved_0__ -> reserved w+      w@WorkerOp_Reserved_2__ -> reserved w+      w@WorkerOp_Reserved_15__ -> reserved w+      w@WorkerOp_Reserved_17__ -> reserved w++      w@WorkerOp_AddBuildLog -> notYet w+      w@WorkerOp_AddMultipleToStore -> notYet w+      w@WorkerOp_BuildPathsWithResults -> notYet w+      w@WorkerOp_ClearFailedPaths -> notYet w+      w@WorkerOp_ExportPath -> notYet w+      w@WorkerOp_HasSubstitutes -> notYet w+      w@WorkerOp_ImportPaths -> notYet w+      w@WorkerOp_QueryDerivationOutputMap -> notYet w+      w@WorkerOp_QueryDeriver -> notYet w+      w@WorkerOp_QueryFailedPaths -> notYet w+      w@WorkerOp_QueryPathHash -> notYet w+      w@WorkerOp_QueryRealisation -> notYet w+      w@WorkerOp_QuerySubstitutablePathInfo -> notYet w+      w@WorkerOp_QuerySubstitutablePathInfos -> notYet w+      w@WorkerOp_QueryReferences -> notYet w+      w@WorkerOp_RegisterDrvOutput -> notYet w+      w@WorkerOp_SetOptions -> notYet w++  , putS = \case+      Some (AddToStore pathName recursive hashAlgo _repair) -> mapPutE $ do+        putS workerOp WorkerOp_AddToStore++        putS storePathName pathName+        -- obsolete fixed+        putS bool+          $ not+          $ hashAlgo == Some HashAlgo_SHA256+            && (recursive == FileIngestionMethod_FileRecursive)++        putS bool (recursive == FileIngestionMethod_FileRecursive)+        putS someHashAlgo hashAlgo++      Some (AddToStoreNar storePath' metadata repair checkSigs) -> mapPutE $ do+        putS workerOp WorkerOp_AddToStoreNar++        putS storePath storePath'+        putS pathMetadata metadata+        putS bool $ repair == RepairMode_DoRepair+        putS bool $ checkSigs == CheckMode_DontCheck++      Some (AddTextToStore txt paths _repair) -> mapPutE $ do+        putS workerOp WorkerOp_AddTextToStore++        putS storeText txt+        putS (hashSet storePath) paths++      Some (AddSignatures path signatures) -> mapPutE $ do+        putS workerOp WorkerOp_AddSignatures++        putS storePath path+        putS (set signature) signatures++      Some (AddIndirectRoot path) -> mapPutE $ do+        putS workerOp WorkerOp_AddIndirectRoot+        putS storePath path++      Some (AddTempRoot path) -> mapPutE $ do+        putS workerOp WorkerOp_AddTempRoot+        putS storePath path++      Some (BuildPaths derived buildMode') -> mapPutE $ do+        putS workerOp WorkerOp_BuildPaths++        putS (set derivedPath) derived+        putS buildMode buildMode'++      Some (BuildDerivation path drv buildMode') -> mapPutE $ do+        putS workerOp WorkerOp_BuildDerivation++        putS storePath path+        putS derivation drv+        putS buildMode buildMode'++      Some (CollectGarbage GCOptions{..}) -> mapPutE $ do+        putS workerOp WorkerOp_CollectGarbage++        putS enum gcOptionsOperation+        putS (hashSet storePath) 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+        putS workerOp WorkerOp_EnsurePath+        putS storePath path++      Some FindRoots -> mapPutE $ do+        putS workerOp WorkerOp_FindRoots++      Some (IsValidPath path) -> mapPutE $ do+        putS workerOp WorkerOp_IsValidPath+        putS storePath path++      Some (NarFromPath path) -> mapPutE $ do+        putS workerOp WorkerOp_NarFromPath+        putS storePath path++      Some (QueryValidPaths paths substituteMode) -> mapPutE $ do+        putS workerOp WorkerOp_QueryValidPaths++        putS (hashSet storePath) paths+        putS enum substituteMode++      Some QueryAllValidPaths -> mapPutE $ do+        putS workerOp WorkerOp_QueryAllValidPaths++      Some (QuerySubstitutablePaths paths) -> mapPutE $ do+        putS workerOp WorkerOp_QuerySubstitutablePaths+        putS (hashSet storePath) paths++      Some (QueryPathInfo path) -> mapPutE $ do+        putS workerOp WorkerOp_QueryPathInfo+        putS storePath path++      Some (QueryReferrers path) -> mapPutE $ do+        putS workerOp WorkerOp_QueryReferrers+        putS storePath path++      Some (QueryValidDerivers path) -> mapPutE $ do+        putS workerOp WorkerOp_QueryValidDerivers+        putS storePath path++      Some (QueryDerivationOutputs path) -> mapPutE $ do+        putS workerOp WorkerOp_QueryDerivationOutputs+        putS storePath path++      Some (QueryDerivationOutputNames path) -> mapPutE $ do+        putS workerOp WorkerOp_QueryDerivationOutputNames+        putS storePath path++      Some (QueryPathFromHashPart pathHashPart) -> mapPutE $ do+        putS workerOp WorkerOp_QueryPathFromHashPart+        putS storePathHashPart pathHashPart++      Some (QueryMissing derived) -> mapPutE $ do+        putS workerOp WorkerOp_QueryMissing+        putS (set derivedPath) derived++      Some OptimiseStore -> mapPutE $ do+        putS workerOp WorkerOp_OptimiseStore++      Some SyncWithGC -> mapPutE $ do+        putS workerOp WorkerOp_SyncWithGC++      Some (VerifyStore checkMode repairMode) -> mapPutE $ do+        putS workerOp WorkerOp_VerifyStore+        putS enum checkMode+        putS enum repairMode+  }+  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++    notYet+      :: MonadError RequestSError m+      => WorkerOp+      -> m a+    notYet = throwError . RequestSError_NotYetImplemented++    reserved+      :: MonadError RequestSError m+      => WorkerOp+      -> m a+    reserved = throwError . RequestSError_ReservedOp++-- ** Reply++data ReplySError+  = ReplySError_PrimGet SError+  | ReplySError_PrimPut SError+  | ReplySError_DerivationOutput SError+  | ReplySError_GCResult SError+  | ReplySError_Metadata SError+  | ReplySError_Missing SError+  | ReplySError_Realisation SError+  | ReplySError_RealisationWithId SError+  | ReplySError_UnexpectedFalseOpSuccess+  deriving (Eq, Ord, Generic, Show)++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++-- | 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 = Serializer+  { getS = do+      retCode <- mapGetER $ getS bool+      Control.Monad.unless+        (retCode == True)+        $ throwError ReplySError_UnexpectedFalseOpSuccess+      pure SuccessCodeReply+  , putS = \_ -> mapPutER $ putS bool True+  }++noop :: a -> NixSerializer r ReplySError a+noop ret = Serializer+  { getS = pure ret+  , putS = \_ -> pure ()+  }++-- *** Realisation++derivationOutputTyped :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName)+derivationOutputTyped = mapErrorS ReplySError_DerivationOutput $+  mapPrismSerializer+    ( Data.Bifunctor.first SError_DerivationOutput+      . System.Nix.Realisation.derivationOutputParser+          System.Nix.OutputName.mkOutputName+    )+    ( Data.Text.Lazy.toStrict+      . Data.Text.Lazy.Builder.toLazyText+      . System.Nix.Realisation.derivationOutputBuilder+          System.Nix.OutputName.unOutputName+    )+    text++realisation :: NixSerializer r ReplySError Realisation+realisation = mapErrorS ReplySError_Realisation json++realisationWithId :: NixSerializer r ReplySError RealisationWithId+realisationWithId = mapErrorS ReplySError_RealisationWithId json++-- *** BuildResult++buildResult+  :: ( HasProtoVersion r+     , HasStoreDir r+     )+  => NixSerializer r ReplySError BuildResult+buildResult = Serializer+  { getS = do+      pv <- Control.Monad.Reader.asks hasProtoVersion++      buildResultStatus <- mapGetER $ getS enum+      buildResultErrorMessage <- mapGetER $ getS maybeText++      ( buildResultTimesBuilt+        , buildResultIsNonDeterministic+        , buildResultStartTime+        , buildResultStopTime+        ) <-+        if protoVersion_minor pv >= 29+        then mapGetER $ do+          tb <- (\case 0 -> Nothing; x -> Just x) <$> getS int+          nondet <- getS bool+          start <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time+          end <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time+          pure $ (tb, pure nondet, start, end)+        else pure $ (Nothing, Nothing, Nothing, Nothing)++      buildResultBuiltOutputs <-+        if protoVersion_minor pv >= 28+        then+            pure+          . Data.Map.Strict.fromList+          . map (\(_, RealisationWithId (a, b)) -> (a, b))+          . Data.Map.Strict.toList+          <$> getS (mapS derivationOutputTyped realisationWithId)+        else pure Nothing+      pure BuildResult{..}++  , putS = \BuildResult{..} -> do+      pv <- Control.Monad.Reader.asks hasProtoVersion++      mapPutER $ putS enum buildResultStatus+      mapPutER $ putS maybeText buildResultErrorMessage+      Control.Monad.when (protoVersion_minor pv >= 29) $ mapPutER $ do+        putS int $ Data.Maybe.fromMaybe 0 buildResultTimesBuilt+        putS bool $ Data.Maybe.fromMaybe False buildResultIsNonDeterministic+        putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime+        putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime+      Control.Monad.when (protoVersion_minor pv >= 28)+        $ putS (mapS derivationOutputTyped realisationWithId)+        $ Data.Map.Strict.fromList+        $ map (\(a, b) -> (a, RealisationWithId (a, b)))+        $ Data.Map.Strict.toList+        $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs+  }+  where+    t0 :: UTCTime+    t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0++-- *** GCResult++gcResult+  :: HasStoreDir r+  => NixSerializer r ReplySError GCResult+gcResult = mapErrorS ReplySError_GCResult $ Serializer+  { getS = do+      gcResultDeletedPaths <- getS (hashSet storePath)+      gcResultBytesFreed <- getS int+      Control.Monad.void $ getS (int @Word64) -- obsolete+      pure GCResult{..}+  , putS = \GCResult{..} -> do+      putS (hashSet storePath) gcResultDeletedPaths+      putS int gcResultBytesFreed+      putS (int @Word64) 0 -- obsolete+  }++-- *** GCRoot++gcRoot :: NixSerializer r 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+      GCRoot_Censored -> censored+      GCRoot_Path p -> p+  }+  where censored = Data.ByteString.Char8.pack "{censored}"++-- *** Missing++missing+  :: HasStoreDir r+  => NixSerializer r ReplySError Missing+missing = mapErrorS ReplySError_Missing $ Serializer+  { getS = do+      missingWillBuild <- getS (hashSet storePath)+      missingWillSubstitute <- getS (hashSet storePath)+      missingUnknownPaths <- getS (hashSet storePath)+      missingDownloadSize <- getS int+      missingNarSize <- getS int++      pure Missing{..}+  , putS = \Missing{..} -> do+      putS (hashSet storePath) missingWillBuild+      putS (hashSet storePath) missingWillSubstitute+      putS (hashSet storePath) missingUnknownPaths+      putS int missingDownloadSize+      putS int missingNarSize+  }++-- *** Maybe (Metadata StorePath)++maybePathMetadata+  :: HasStoreDir r+  => NixSerializer r ReplySError (Maybe (Metadata StorePath))+maybePathMetadata = mapErrorS ReplySError_Metadata $ Serializer+  { getS = do+      valid <- getS bool+      if valid+      then pure <$> getS pathMetadata+      else pure Nothing+  , putS = \case+      Nothing -> putS bool False+      Just pm -> putS bool True >> putS pathMetadata pm+  }

@@ -0,0 +1,365 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+module System.Nix.Store.Remote.Server+  ( runProxyDaemon+  , WorkerHelper+  )+  where++import Control.Concurrent.Classy.Async+import Control.Monad (join, void, when)+import Control.Monad.Conc.Class (MonadConc)+import Control.Monad.Except (MonadError, throwError)+import Control.Monad.Trans (lift)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Default.Class (Default(def))+import Data.Foldable (traverse_)+import Data.IORef (IORef, atomicModifyIORef, newIORef)+import Data.Text (Text)+import Data.Void (Void, absurd)+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.Socket+import System.Nix.Store.Remote.Types.StoreRequest as R+import System.Nix.Store.Remote.Types.StoreReply+import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..))+import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..))+import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT)+import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), ServerHandshakeOutput(..))+import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))+import qualified Data.Some+import qualified Data.Text+import qualified Data.Text.IO+import qualified System.Timeout+import qualified Network.Socket.ByteString++type WorkerHelper m+  = forall a+  . ( Show a+    , StoreReply a+    )+  => RemoteStoreT m a+  -> Run m a++chatty :: Bool+chatty = False++dbg :: MonadIO m => Text -> m ()+dbg = when chatty . liftIO . Data.Text.IO.putStrLn++-- | Run an emulated nix daemon on given socket address.+-- The deamon will close when the continuation returns.+runProxyDaemon+  :: forall m a+  . ( MonadIO m+    , MonadConc m+    )+  => WorkerHelper m+  -> RemoteStoreT m ()+  -> Socket+  -> m a+  -> m a+runProxyDaemon workerHelper postGreet lsock k = do+  liftIO $ listen lsock maxListenQueue++  dbg "listening"++  let listener :: m Void+      listener = do+        (sock, _) <- liftIO $ accept lsock+        dbg "accepting"++        -- TODO: this, but without the space leak+        fmap fst+          $ concurrently listener+          $ processConnection workerHelper postGreet sock++  either absurd id <$> race listener k++-- | "main loop" of the daemon for a single connection.+--+-- this function should take care to not throw errors from client connections.+processConnection+  :: forall m+  .  MonadIO m+  => WorkerHelper m+  -> RemoteStoreT m ()+  -> Socket+  -> m ()+processConnection workerHelper postGreet sock = do+  ~() <- void $ runRemoteStoreT sock $ do++    ServerHandshakeOutput{..}+      <- greet+          ServerHandshakeInput+          { serverHandshakeInputNixVersion = "nixVersion (hnix-store-remote)"+          , serverHandshakeInputOurVersion = def+          , serverHandshakeInputTrust = Nothing+          }++    setProtoVersion serverHandshakeOutputLeastCommonVersion++    tunnelLogger <- liftIO $ newTunnelLogger+    -- Send startup error messages to the client.+    startWork tunnelLogger++    -- TODO: do we need auth at all? probably?+    -- If we can't accept clientVersion, then throw an error *here* (not above).+    --authHook(*store);+    stopWork tunnelLogger++    -- so we can set store dir+    postGreet++    let perform+          :: ( Show a+             , StoreReply a+             )+          => StoreRequest a+          -> RemoteStoreT m ()+        perform req = do++          special <- case req of+            AddToStore {} -> do+              -- This is a hack (but a pretty neat and fast one!)+              -- it should parse nad stream NAR instead+              let proxyNarSource :: NarSource IO+                  proxyNarSource f =+                    liftIO+                      (System.Timeout.timeout+                         1000000+                         (Network.Socket.ByteString.recv sock 8)+                      )+                    >>= \case+                      Nothing -> pure ()+                      Just x -> f x >> proxyNarSource f++              pure $ setNarSource proxyNarSource+            _ -> pure $ pure ()++          res <-+            bracketLogger+              tunnelLogger+              $ lift+              $ workerHelper+              $ special >> doReq req++          case fst res of+            Left e -> throwError e+            Right reply ->+              sockPutS+                (mapErrorS+                   RemoteStoreError_SerializerReply+                   $ getReplyS+                )+                reply++    -- Process client requests.+    let loop = do+          someReq <-+            sockGetS+              $ mapErrorS+                  RemoteStoreError_SerializerRequest+                  storeRequest++          -- have to be explicit here+          -- because otherwise GHC can't conjure Show a, StoreReply a+          -- out of thin air+          () <- Data.Some.withSome someReq $ \case+            r@AddToStore {} -> perform r+            r@AddToStoreNar {} -> perform r+            r@AddTextToStore {} -> perform r+            r@AddSignatures {} -> perform r+            r@AddTempRoot {} -> perform r+            r@AddIndirectRoot {} -> perform r+            r@BuildDerivation {} -> perform r+            r@BuildPaths {} -> perform r+            r@CollectGarbage {} -> perform r+            r@EnsurePath {} -> perform r+            r@FindRoots {} -> perform r+            r@IsValidPath {} -> perform r+            r@NarFromPath {} -> perform r+            r@QueryValidPaths {} -> perform r+            r@QueryAllValidPaths {} -> perform r+            r@QuerySubstitutablePaths {} -> perform r+            r@QueryPathInfo {} -> perform r+            r@QueryReferrers {} -> perform r+            r@QueryValidDerivers {} -> perform r+            r@QueryDerivationOutputs {} -> perform r+            r@QueryDerivationOutputNames {} -> perform r+            r@QueryPathFromHashPart {} -> perform r+            r@QueryMissing {} -> perform r+            r@OptimiseStore {} -> perform r+            r@SyncWithGC {} -> perform r+            r@VerifyStore {} -> perform r+          loop+    loop++  dbg "daemon connection done"+  liftIO $ close sock++  where+    -- Exchange the greeting.+    greet+      :: MonadIO m+      => ServerHandshakeInput+      -> RemoteStoreT m ServerHandshakeOutput+    greet ServerHandshakeInput{..} = do+      magic <-+        sockGetS+        $ mapErrorS+            RemoteStoreError_SerializerHandshake+            workerMagic++      when (magic /= WorkerMagic_One)+        $ throwError+        $ RemoteStoreError_WorkerException+            WorkerException_ProtocolMismatch++      sockPutS+        (mapErrorS+          RemoteStoreError_SerializerHandshake+          workerMagic+        )+        WorkerMagic_Two++      sockPutS protoVersion serverHandshakeInputOurVersion++      clientVersion <- sockGetS protoVersion++      let leastCommonVersion = min clientVersion serverHandshakeInputOurVersion++      when (clientVersion < ProtoVersion 1 10)+        $ throwError+        $ RemoteStoreError_WorkerException+            WorkerException_ClientVersionTooOld++      when (clientVersion >= ProtoVersion 1 14) $ do+        x :: Word32 <- sockGetS int+        when (x /= 0) $ do+          -- Obsolete CPU affinity.+          _ :: Word32 <- sockGetS int+          pure ()++      when (clientVersion >= ProtoVersion 1 11) $ do+        _ :: Word32 <- sockGetS int -- obsolete reserveSpace+        pure ()++      when (clientVersion >= ProtoVersion 1 33) $ do+        sockPutS+          (mapErrorS+             RemoteStoreError_SerializerPut+             text+          )+          serverHandshakeInputNixVersion++      when (clientVersion >= ProtoVersion 1 35) $ do+        sockPutS+          (mapErrorS+             RemoteStoreError_SerializerHandshake+             trustedFlag+          )+          serverHandshakeInputTrust++      pure ServerHandshakeOutput+        { serverHandshakeOutputLeastCommonVersion = leastCommonVersion+        , serverHandshakeOutputClientVersion = clientVersion+        }++{-# WARNING _unimplemented "not yet implemented" #-}+_unimplemented :: RemoteStoreError+_unimplemented = RemoteStoreError_WorkerException $ WorkerException_Error $ WorkerError_NotYetImplemented++bracketLogger+  :: MonadRemoteStore m+  => TunnelLogger+  -> m a+  -> m a+bracketLogger tunnelLogger m = do+  startWork tunnelLogger+  a <- m+  stopWork tunnelLogger+  pure a++---++data TunnelLogger = TunnelLogger+  { _tunnelLogger_state :: IORef TunnelLoggerState+  }++data TunnelLoggerState = TunnelLoggerState+  { _tunnelLoggerState_canSendStderr :: Bool+  , _tunnelLoggerState_pendingMsgs :: [Logger]+  }++newTunnelLogger :: IO TunnelLogger+newTunnelLogger = TunnelLogger <$> newIORef (TunnelLoggerState False [])++enqueueMsg+  :: ( MonadRemoteStore m+     , MonadError LoggerSError m+     )+  => 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 ())++_log+  :: ( MonadRemoteStore m+     , MonadError LoggerSError m+     )+  => TunnelLogger+  -> Text+  -> m ()+_log l s = enqueueMsg l (Logger_Next s)++startWork+  :: MonadRemoteStore m+  => TunnelLogger+  -> m ()+startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,)+  (TunnelLoggerState True []) $+  (traverse_ (sockPutS logger') $ reverse p)+  where logger' = mapErrorS RemoteStoreError_SerializerLogger logger++stopWork+  :: MonadRemoteStore m+  => TunnelLogger+  -> m ()+stopWork x = updateLogger x $ \_ -> (,)+  (TunnelLoggerState False [])+  (sockPutS (mapErrorS RemoteStoreError_SerializerLogger logger) Logger_Last)++-- | Stop sending logging and report an error.+--+-- Returns true if the the session was in a state that allowed the error to be+-- sent.+--+-- Unlike 'stopWork', this function may be called at any time to (try) to end a+-- session with an error.+_stopWorkOnError+  :: MonadRemoteStore m+  => TunnelLogger+  -> ErrorInfo+  -> m Bool+_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+        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+  => TunnelLogger+  -> (TunnelLoggerState -> (TunnelLoggerState, m a))+  -> m a+updateLogger x = join . liftIO . atomicModifyIORef (_tunnelLogger_state x)

@@ -0,0 +1,101 @@+module System.Nix.Store.Remote.Socket where++import Control.Monad.Except (MonadError, throwError)+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 qualified Control.Exception+import qualified Data.ByteString+import qualified Data.Serializer+import qualified Data.Serialize.Get++genericIncremental+  :: ( MonadIO m+     , MonadError RemoteStoreError m+     , Show a+     )+  => m ByteString+  -> Get a+  -> m a+genericIncremental getsome parser = do+  getsome >>= go . decoder+ where+  decoder = Data.Serialize.Get.runGetPartial parser+  go (Done x leftover) | leftover /= mempty =+    throwError+    $ RemoteStoreError_GenericIncrementalLeftovers+        (show x)+        leftover++  go (Done x _leftover) = pure x++  go (Partial k) = do+    chunk <- getsome+    go (k chunk)++  go (Fail msg leftover) =+    throwError+    $ RemoteStoreError_GenericIncrementalFail+        msg+        leftover++sockGet8+  :: MonadRemoteStore m+  => m ByteString+sockGet8 = do+  soc <- getStoreSocket+  eresult <- liftIO $ Control.Exception.try $ recv soc 8+  case eresult of+    Left e ->+      throwError $ RemoteStoreError_IOException e++    Right result | Data.ByteString.length result == 0 ->+      throwError RemoteStoreError_Disconnected++    Right result | otherwise ->+      pure result++sockPut+  :: MonadRemoteStore m+  => Put+  -> m ()+sockPut p = do+  soc <- getStoreSocket+  liftIO $ sendAll soc $ runPut p++sockPutS+  :: ( MonadRemoteStore m+     , MonadError e m+     )+  => NixSerializer ProtoStoreConfig 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++sockGetS+  :: ( MonadRemoteStore m+     , MonadError e m+     , Show a+     , Show e+     )+  => NixSerializer ProtoStoreConfig e a+  -> m a+sockGetS s = do+  cfg <- getConfig+  res <- genericIncremental sockGet8+    $ runSerialT cfg $ Data.Serializer.getS s++  case res of+    Right x -> pure x+    Left e -> throwError e

@@ -1,77 +1,33 @@-{-# language DataKinds #-}-{-# language KindSignatures #-}-{-# language ScopedTypeVariables #-} module System.Nix.Store.Remote.Types-  ( MonadStore-  , StoreConfig(..)-  , Logger(..)-  , Field(..)-  , getStoreDir-  , getLog-  , flushLog-  , gotError-  , getError-  , setData-  , clearData-  )-where---import qualified Data.ByteString.Lazy          as BSL-import           Network.Socket                 ( Socket )--data StoreConfig = StoreConfig-  { storeDir    :: FilePath-  , storeSocket :: Socket-  }--type MonadStore a-  = ExceptT-      String-      (StateT (Maybe BSL.ByteString, [Logger]) (ReaderT StoreConfig IO))-      a--type ActivityID = Int-type ActivityParentID = Int-type ActivityType = Int-type Verbosity = Int-type ResultType = Int--data Field = LogStr ByteString | LogInt Int-  deriving (Eq, Ord, Show)--data Logger =-    Next          ByteString-  | Read          Int            -- data needed from source-  | Write         ByteString -- data for sink-  | Last-  | Error         Int ByteString-  | StartActivity ActivityID Verbosity ActivityType ByteString [Field] ActivityParentID-  | StopActivity  ActivityID-  | Result        ActivityID ResultType [Field]-  deriving (Eq, Ord, Show)--isError :: Logger -> Bool-isError (Error _ _) = True-isError _           = False--gotError :: MonadStore Bool-gotError = gets (any isError . snd)--getError :: MonadStore [Logger]-getError = gets (filter isError . snd)--getLog :: MonadStore [Logger]-getLog = gets snd--flushLog :: MonadStore ()-flushLog = modify (\(a, _b) -> (a, []))--setData :: BSL.ByteString -> MonadStore ()-setData x = modify (\(_, b) -> (Just x, b))--clearData :: MonadStore ()-clearData = modify (\(_, b) -> (Nothing, b))+  ( module System.Nix.Store.Remote.Types.Activity+  , module System.Nix.Store.Remote.Types.GC+  , module System.Nix.Store.Remote.Types.CheckMode+  , module System.Nix.Store.Remote.Types.Logger+  , module System.Nix.Store.Remote.Types.ProtoVersion+  , module System.Nix.Store.Remote.Types.Query+  , module System.Nix.Store.Remote.Types.StoreConfig+  , module System.Nix.Store.Remote.Types.StoreRequest+  , module System.Nix.Store.Remote.Types.StoreText+  , module System.Nix.Store.Remote.Types.SubstituteMode+  , module System.Nix.Store.Remote.Types.SuccessCodeReply+  , module System.Nix.Store.Remote.Types.TrustedFlag+  , module System.Nix.Store.Remote.Types.Verbosity+  , module System.Nix.Store.Remote.Types.WorkerMagic+  , module System.Nix.Store.Remote.Types.WorkerOp+  ) where -getStoreDir :: MonadStore FilePath-getStoreDir = asks storeDir+import System.Nix.Store.Remote.Types.Activity+import System.Nix.Store.Remote.Types.GC+import System.Nix.Store.Remote.Types.CheckMode+import System.Nix.Store.Remote.Types.Logger+import System.Nix.Store.Remote.Types.ProtoVersion+import System.Nix.Store.Remote.Types.Query+import System.Nix.Store.Remote.Types.StoreConfig+import System.Nix.Store.Remote.Types.StoreRequest+import System.Nix.Store.Remote.Types.StoreText+import System.Nix.Store.Remote.Types.SubstituteMode+import System.Nix.Store.Remote.Types.SuccessCodeReply+import System.Nix.Store.Remote.Types.TrustedFlag+import System.Nix.Store.Remote.Types.Verbosity+import System.Nix.Store.Remote.Types.WorkerMagic+import System.Nix.Store.Remote.Types.WorkerOp

@@ -0,0 +1,55 @@+module System.Nix.Store.Remote.Types.Activity+  ( Activity(..)+  , ActivityID(..)+  , ActivityResult(..)+  ) where++import GHC.Generics++-- | Type of the activity+--+-- We don't have Activity_Unknown here+-- as we can do @Maybe Activity@ and @Nothing@+-- corresponding to Unknown (which has 0 value)+--+-- Rest of the values are offset by @(+100)@+-- on the wire, i.e.:+--+--   * @Activity_CopyPath = 100@+--   * @Activity_BuildWaiting = 111@+data Activity+  = Activity_CopyPath+  | Activity_FileTransfer+  | Activity_Realise+  | Activity_CopyPaths+  | Activity_Builds+  | Activity_Build+  | Activity_OptimiseStore+  | Activity_VerifyPaths+  | Activity_Substitute+  | Activity_QueryPathInfo+  | Activity_PostBuildHook+  | Activity_BuildWaiting+  deriving (Bounded, Eq, Enum, Generic, Ord, Show)++-- | Numeric ID of the activity+newtype ActivityID = ActivityID { unActivityID :: Int }+  deriving (Eq, Generic, Ord, Show)++-- | Result of some activity+--+-- The values are offset by @(+100)@+-- on the wire, i.e.:+--+--   * @ActivityResult_FileLinked = 100@+--   * @ActivityResult_PostBuildLogLine = 107@+data ActivityResult+  = ActivityResult_FileLinked+  | ActivityResult_BuildLogLine+  | ActivityResult_UnstrustedPath+  | ActivityResult_CorruptedPath+  | ActivityResult_SetPhase+  | ActivityResult_Progress+  | ActivityResult_SetExpected+  | ActivityResult_PostBuildLogLine+  deriving (Bounded, Eq, Enum, Generic, Ord, Show)

@@ -0,0 +1,11 @@+module System.Nix.Store.Remote.Types.CheckMode+  ( CheckMode(..)+  ) where++import GHC.Generics++-- | Check mode, used by @verifyStore@+data CheckMode+  = CheckMode_DoCheck+  | CheckMode_DontCheck+  deriving (Bounded, Eq, Generic, Enum, Ord, Show)

@@ -0,0 +1,55 @@+{-|+Description : Garbage collection actions / options+Maintainer  : srk <srk@48.io>+|-}+module System.Nix.Store.Remote.Types.GC (+    GCAction(..)+  , GCOptions(..)+  , GCResult(..)+  , GCRoot(..)+  ) where++import Data.HashSet (HashSet)+import Data.Word (Word64)+import GHC.Generics (Generic)+import System.Nix.StorePath (StorePath)+import System.Posix.ByteString (RawFilePath)++-- | Garbage collection action+data GCAction+  = GCAction_ReturnLive -- ^ Return the set of paths reachable from roots (closure)+  | GCAction_ReturnDead -- ^ Return unreachable paths+  | GCAction_DeleteDead -- ^ Delete unreachable paths+  | GCAction_DeleteSpecific -- ^ Delete specified paths+  deriving (Bounded, Eq, Enum, Generic, Ord, Show)++-- | Garbage collector operation options+data GCOptions = GCOptions+  { -- | Operation+    gcOptionsOperation :: GCAction+    -- | If set, then reachability from the roots is ignored (unused)+  , gcOptionsIgnoreLiveness :: Bool+    -- | Paths to delete for @GCAction_DeleteSpecific@+  , gcOptionsPathsToDelete :: HashSet StorePath+    -- | Stop after `gcOptions_maxFreed` bytes have been freed+  , gcOptionsMaxFreed :: Word64+  } deriving (Eq, Generic, Ord, Show)++-- | Result of the garbage collection operation+data GCResult = GCResult+ { -- | Depending on the action, the GC roots,+   -- or the paths that would be or have been deleted+   gcResultDeletedPaths :: HashSet StorePath+   -- | The number of bytes that would be or was freed for+   --+   --      - @GCAction_ReturnDead@+   --      - @GCAction_DeleteDead@+   --      - @GCAction_DeleteSpecific@+ , gcResultBytesFreed :: Word64+ } deriving (Eq, Generic, Ord, Show)++-- | Used as a part of the result of @FindRoots@ operation+data GCRoot+  = GCRoot_Censored -- ^ Source path is censored since the user is not trusted+  | GCRoot_Path RawFilePath -- ^ Raw source path+  deriving (Eq, Generic, Ord, Show)

@@ -0,0 +1,37 @@+module System.Nix.Store.Remote.Types.Handshake+  ( ClientHandshakeInput(..)+  , ClientHandshakeOutput(..)+  , ServerHandshakeInput(..)+  , ServerHandshakeOutput(..)+  ) where++import Data.Text (Text)+import GHC.Generics (Generic)+import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion)+import System.Nix.Store.Remote.Types.TrustedFlag (TrustedFlag)++-- | Data sent by the client during initial protocol handshake+data ClientHandshakeInput = ClientHandshakeInput+  { clientHandshakeInputOurVersion :: ProtoVersion -- ^ Our protocol version (that we advertise to the server)+  } deriving (Eq, Generic, Ord, Show)++-- | Data received by the client via initial protocol handshake+data ClientHandshakeOutput = ClientHandshakeOutput+  { clientHandshakeOutputNixVersion :: Maybe Text -- ^ Textual version, since 1.33+  , clientHandshakeOutputTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us+  , clientHandshakeOutputLeastCommonVersion :: ProtoVersion -- ^ Minimum protocol version supported by both sides+  , clientHandshakeOutputServerVersion :: ProtoVersion -- ^ Protocol version supported by the server+  } deriving (Eq, Generic, Ord, Show)++-- | Data sent by the server during initial protocol handshake+data ServerHandshakeInput = ServerHandshakeInput+  { serverHandshakeInputNixVersion :: Text -- ^ Textual version, since 1.33+  , serverHandshakeInputOurVersion :: ProtoVersion -- ^ Our protocol version (that we advertise to the client)+  , serverHandshakeInputTrust :: Maybe TrustedFlag -- ^ Whether client should trusts us+  } deriving (Eq, Generic, Ord, Show)++-- | Data received by the server during initial protocol handshake+data ServerHandshakeOutput = ServerHandshakeOutput+  { serverHandshakeOutputLeastCommonVersion :: ProtoVersion -- ^ Minimum protocol version supported by both sides+  , serverHandshakeOutputClientVersion :: ProtoVersion -- ^ Protocol version supported by the client+  } deriving (Eq, Generic, Ord, Show)

@@ -0,0 +1,108 @@+module System.Nix.Store.Remote.Types.Logger+  ( Field(..)+  , Trace(..)+  , BasicError(..)+  , ErrorInfo(..)+  , Logger(..)+  , LoggerOpCode(..)+  , loggerOpCodeToWord64+  , word64ToLoggerOpCode+  , isError+  ) where++import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Word (Word64)+import GHC.Generics+import System.Nix.Store.Remote.Types.Activity (Activity, ActivityID, ActivityResult)+import System.Nix.Store.Remote.Types.Verbosity (Verbosity)++data Field+  = Field_LogStr Text+  | Field_LogInt Int+  deriving (Eq, Generic, Ord, Show)++-- | Error trace+data Trace = Trace+  { tracePosition :: Maybe Int -- Error position, Nix always writes 0 here+  , traceHint :: Text+  }+  deriving (Eq, Generic, Ord, Show)++data BasicError = BasicError+  { basicErrorExitStatus :: Int+  , basicErrorMessage :: Text+  }+  deriving (Eq, Generic, Ord, Show)++-- | Extended error info+-- available for protoVersion_minor >= 26+data ErrorInfo = ErrorInfo+  { errorInfoLevel :: Verbosity+  , errorInfoMessage :: Text+  , errorInfoPosition :: Maybe Int -- Error position, Nix always writes 0 here+  , errorInfoTraces :: [Trace]+  }+  deriving (Eq, Generic, Ord, Show)++data LoggerOpCode+  = LoggerOpCode_Next+  | LoggerOpCode_Read+  | LoggerOpCode_Write+  | LoggerOpCode_Last+  | LoggerOpCode_Error+  | LoggerOpCode_StartActivity+  | LoggerOpCode_StopActivity+  | LoggerOpCode_Result+  deriving (Eq, Generic, Ord, Show)++loggerOpCodeToWord64 :: LoggerOpCode -> Word64+loggerOpCodeToWord64 = \case+  LoggerOpCode_Next -> 0x6f6c6d67+  LoggerOpCode_Read -> 0x64617461+  LoggerOpCode_Write -> 0x64617416+  LoggerOpCode_Last -> 0x616c7473+  LoggerOpCode_Error -> 0x63787470+  LoggerOpCode_StartActivity -> 0x53545254+  LoggerOpCode_StopActivity -> 0x53544f50+  LoggerOpCode_Result -> 0x52534c54++word64ToLoggerOpCode :: Word64 -> Either String LoggerOpCode+word64ToLoggerOpCode = \case+  0x6f6c6d67 -> Right LoggerOpCode_Next+  0x64617461 -> Right LoggerOpCode_Read+  0x64617416 -> Right LoggerOpCode_Write+  0x616c7473 -> Right LoggerOpCode_Last+  0x63787470 -> Right LoggerOpCode_Error+  0x53545254 -> Right LoggerOpCode_StartActivity+  0x53544f50 -> Right LoggerOpCode_StopActivity+  0x52534c54 -> Right LoggerOpCode_Result+  x -> Left $ "Invalid LoggerOpCode: " ++ show x++data Logger+  = Logger_Next Text+  | Logger_Read Word64      -- data needed from source+  | Logger_Write ByteString -- data for sink+  | Logger_Last+  | Logger_Error (Either BasicError ErrorInfo)+  | Logger_StartActivity+      { startActivityID :: ActivityID+      , startActivityVerbosity :: Verbosity+      , startActivityType :: Maybe Activity+      , startActivityString :: ByteString+      , startActivityFields :: [Field]+      , startActivityParentID :: ActivityID+      }+  | Logger_StopActivity+      { stopActivityID :: ActivityID+      }+  | Logger_Result+      { resultActivityID :: ActivityID+      , resultType :: ActivityResult+      , resultFields :: [Field]+      }+  deriving (Eq, Generic, Ord, Show)++isError :: Logger -> Bool+isError Logger_Error {} = True+isError _ = False

@@ -0,0 +1,8 @@+module System.Nix.Store.Remote.Types.NoReply+  ( NoReply(..)+  ) where++-- | Reply type for the case where the server does not reply+data NoReply = NoReply+  deriving (Show)+

@@ -0,0 +1,27 @@+module System.Nix.Store.Remote.Types.ProtoVersion+  ( ProtoVersion(..)+  , HasProtoVersion(..)+  ) where++import Data.Default.Class (Default(def))+import Data.Word (Word8, Word16)+import GHC.Generics (Generic)++data ProtoVersion = ProtoVersion+  { protoVersion_major :: Word16+  , protoVersion_minor :: Word8+  }+  deriving (Eq, Generic, Ord, Show)++-- | The protocol version we support+instance Default ProtoVersion where+  def = ProtoVersion+    { protoVersion_major = 1+    , protoVersion_minor = 24+    }++class HasProtoVersion r where+  hasProtoVersion :: r -> ProtoVersion++instance HasProtoVersion ProtoVersion where+  hasProtoVersion = id

@@ -0,0 +1,5 @@+module System.Nix.Store.Remote.Types.Query+  ( module System.Nix.Store.Remote.Types.Query.Missing+  ) where++import System.Nix.Store.Remote.Types.Query.Missing

@@ -0,0 +1,18 @@+module System.Nix.Store.Remote.Types.Query.Missing+  ( Missing(..)+  ) where++import Data.HashSet (HashSet)+import Data.Word (Word64)+import GHC.Generics (Generic)+import System.Nix.StorePath (StorePath)++-- | Result of @QueryMissing@ @StoreRequest@+data Missing = Missing+  { missingWillBuild :: HashSet StorePath -- ^ Paths that will be built+  , missingWillSubstitute :: HashSet StorePath -- ^ Paths that can be substituted from cache+  , missingUnknownPaths :: HashSet StorePath -- ^ Path w/o any information+  , missingDownloadSize :: Word64 -- ^ Total size of packed NARs to download+  , missingNarSize :: Word64 -- ^ Total size of NARs after unpacking+  }+  deriving (Eq, Generic, Ord, Show)

@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module System.Nix.Store.Remote.Types.StoreConfig+  ( ProtoStoreConfig(..)+  , StoreSocketPath(..)+  , StoreTCP(..)+  , StoreConnection(..)+  , HasStoreSocket(..)+  ) where++import Data.Default.Class (Default(def))+import Data.String (IsString)+import GHC.Generics (Generic)+import Network.Socket (Socket)+import System.Nix.StorePath (HasStoreDir(..), StoreDir)+import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion)++class HasStoreSocket r where+  hasStoreSocket :: r -> Socket++instance HasStoreSocket Socket where+  hasStoreSocket = id++data ProtoStoreConfig = ProtoStoreConfig+  { protoStoreConfigDir :: StoreDir+  , protoStoreConfigProtoVersion :: ProtoVersion+  } deriving (Eq, Generic, Ord, Show)++instance Default ProtoStoreConfig where+  def = ProtoStoreConfig def def++instance HasStoreDir StoreDir where+  hasStoreDir = id++instance HasStoreDir ProtoStoreConfig where+  hasStoreDir = protoStoreConfigDir++instance HasProtoVersion ProtoStoreConfig where+  hasProtoVersion = protoStoreConfigProtoVersion++newtype StoreSocketPath = StoreSocketPath+  { unStoreSocketPath :: FilePath+  }+  deriving newtype (IsString)+  deriving stock (Eq, Generic, Ord, Show)++instance Default StoreSocketPath where+  def = StoreSocketPath "/nix/var/nix/daemon-socket/socket"++data StoreTCP = StoreTCP+  { storeTCPHost :: String+  , storeTCPPort :: Int+  } deriving (Eq, Generic, Ord, Show)++data StoreConnection+  = StoreConnection_Socket StoreSocketPath+  | StoreConnection_TCP StoreTCP+  deriving (Eq, Generic, Ord, Show)++instance Default StoreConnection where+  def = StoreConnection_Socket def

@@ -0,0 +1,61 @@+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

@@ -0,0 +1,202 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}++module System.Nix.Store.Remote.Types.StoreRequest+  ( StoreRequest(..)+  ) where++import Data.GADT.Compare.TH (deriveGEq, deriveGCompare)+import Data.GADT.Show.TH (deriveGShow)+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.DerivedPath (DerivedPath)+import System.Nix.Hash (HashAlgo)+import System.Nix.Signature (Signature)+import System.Nix.Store.Types (FileIngestionMethod, RepairMode)+import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart)+import System.Nix.StorePath.Metadata (Metadata)+import System.Nix.Store.Remote.Types.GC (GCOptions, GCResult, GCRoot)+import System.Nix.Store.Remote.Types.CheckMode (CheckMode)+import System.Nix.Store.Remote.Types.NoReply (NoReply)+import System.Nix.Store.Remote.Types.Query.Missing (Missing)+import System.Nix.Store.Remote.Types.StoreText (StoreText)+import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode)+import System.Nix.Store.Remote.Types.SuccessCodeReply (SuccessCodeReply)++data StoreRequest :: Type -> Type where+  -- | Add @NarSource@ to the store.+  AddToStore+    :: StorePathName -- ^ Name part of the newly created @StorePath@+    -> FileIngestionMethod -- ^ Add target directory recursively+    -> Some HashAlgo -- ^ Nar hashing algorithm+    -> RepairMode -- ^ Only used by local store backend+    -> StoreRequest StorePath++  -- | Add a NAR with Metadata to the store.+  AddToStoreNar+    :: StorePath+    -> Metadata StorePath+    -> RepairMode+    -> CheckMode -- ^ Whether to check signatures+    -> StoreRequest NoReply++  -- | Add text to store.+  --+  -- Reference accepts repair but only uses it+  -- to throw error in case of remote talking to nix-daemon.+  AddTextToStore+    :: StoreText+    -> HashSet StorePath -- ^ Set of @StorePath@s that the added text references+    -> RepairMode -- ^ Repair mode, must be @RepairMode_DontRepair@ in case of remote backend+    -> StoreRequest StorePath++  AddSignatures+    :: StorePath+    -> Set Signature+    -> StoreRequest SuccessCodeReply++  AddIndirectRoot+    :: StorePath+    -> StoreRequest SuccessCodeReply++  -- | Add temporary garbage collector root.+  --+  -- This root is removed as soon as the client exits.+  AddTempRoot+    :: StorePath+    -> StoreRequest SuccessCodeReply++  -- | Build paths if they are an actual derivations.+  --+  -- If derivation output paths are already valid, do nothing.+  BuildPaths+    :: Set DerivedPath+    -> BuildMode+    -> StoreRequest SuccessCodeReply++  BuildDerivation+    :: StorePath+    -> Derivation StorePath Text+    -> BuildMode+    -> StoreRequest BuildResult++  CollectGarbage+    :: GCOptions+    -> StoreRequest GCResult++  EnsurePath+    :: StorePath+    -> StoreRequest SuccessCodeReply++  -- | Find garbage collector roots.+  FindRoots+    :: StoreRequest (Map GCRoot StorePath)++  IsValidPath+    :: StorePath+    -> StoreRequest Bool++  -- | Fetch a NAR from the server+  NarFromPath+    :: StorePath+    -> StoreRequest NoReply++  -- | Query valid paths from set, optionally try to use substitutes.+  QueryValidPaths+    :: HashSet StorePath+    -- ^ Set of @StorePath@s to query+    -> SubstituteMode+    -- ^ Try substituting missing paths when @SubstituteMode_DoSubstitute@+    -> StoreRequest (HashSet StorePath)++  QueryAllValidPaths+    :: StoreRequest (HashSet StorePath)++  QuerySubstitutablePaths+    :: HashSet StorePath+    -> StoreRequest (HashSet StorePath)++  QueryPathInfo+    :: StorePath+    -> StoreRequest (Maybe (Metadata StorePath))++  QueryReferrers+    :: StorePath+    -> StoreRequest (HashSet StorePath)++  QueryValidDerivers+    :: StorePath+    -> StoreRequest (HashSet StorePath)++  QueryDerivationOutputs+    :: StorePath+    -> StoreRequest (HashSet StorePath)++  QueryDerivationOutputNames+    :: StorePath+    -> StoreRequest (HashSet StorePathName)++  QueryPathFromHashPart+    :: StorePathHashPart+    -> StoreRequest StorePath++  QueryMissing+    :: Set DerivedPath+    -> StoreRequest Missing++  OptimiseStore+    :: StoreRequest SuccessCodeReply++  SyncWithGC+    :: StoreRequest SuccessCodeReply++  -- returns True on errors+  VerifyStore+    :: CheckMode+    -> RepairMode+    -> StoreRequest Bool++deriving instance Eq (StoreRequest a)+deriving instance Show (StoreRequest a)++deriveGEq ''StoreRequest+deriveGCompare ''StoreRequest+deriveGShow ''StoreRequest++instance {-# OVERLAPPING #-} Eq (Some StoreRequest) where+  Some (AddToStore a b c d) == Some (AddToStore a' b' c' d') = (a, b, c, d) == (a', b', c', d')+  Some (AddToStoreNar a b c d) == Some (AddToStoreNar a' b' c' d') = (a, b, c, d) == (a', b', c', d')+  Some (AddTextToStore a b c) == Some (AddTextToStore a' b' c') = (a, b, c) == (a', b', c')+  Some (AddSignatures a b) == Some (AddSignatures a' b') = (a, b) == (a', b')+  Some (AddIndirectRoot a) == Some (AddIndirectRoot a') = a == a'+  Some (AddTempRoot a) == Some (AddTempRoot a') = a == a'+  Some (BuildPaths a b) == Some (BuildPaths a' b') = (a, b) == (a', b')+  Some (BuildDerivation a b c) == Some (BuildDerivation a' b' c') = (a, b, c) == (a', b', c')+  Some (CollectGarbage a) == Some (CollectGarbage a') = a == a'+  Some (EnsurePath a) == Some (EnsurePath a') = a == a'+  Some (FindRoots) == Some (FindRoots) = True+  Some (IsValidPath a) == Some (IsValidPath a') = a == a'+  Some (NarFromPath a) == Some (NarFromPath a') = a == a'+  Some (QueryValidPaths a b) == Some (QueryValidPaths a' b') = (a, b) == (a', b')+  Some QueryAllValidPaths == Some QueryAllValidPaths = True+  Some (QuerySubstitutablePaths a) == Some (QuerySubstitutablePaths a') = a == a'+  Some (QueryPathInfo a) == Some (QueryPathInfo a') = a == a'+  Some (QueryReferrers a) == Some (QueryReferrers a') = a == a'+  Some (QueryValidDerivers a) == Some (QueryValidDerivers a') = a == a'+  Some (QueryDerivationOutputs a) == Some (QueryDerivationOutputs a') = a == a'+  Some (QueryDerivationOutputNames a) == Some (QueryDerivationOutputNames a') = a == a'+  Some (QueryPathFromHashPart a) == Some (QueryPathFromHashPart a') = a == a'+  Some (QueryMissing a) == Some (QueryMissing a') = a == a'+  Some OptimiseStore == Some OptimiseStore = True+  Some SyncWithGC == Some SyncWithGC = True+  Some (VerifyStore a b) == Some (VerifyStore a' b') = (a, b) == (a', b')++  _ == _ = False

@@ -0,0 +1,12 @@+module System.Nix.Store.Remote.Types.StoreText+  ( StoreText(..)+  ) where++import Data.Text (Text)+import GHC.Generics (Generic)+import System.Nix.StorePath (StorePathName)++data StoreText = StoreText+  { storeTextName :: StorePathName+  , storeTextText :: Text+  } deriving (Eq, Generic, Ord, Show)

@@ -0,0 +1,11 @@+module System.Nix.Store.Remote.Types.SubstituteMode+  ( SubstituteMode(..)+  ) where++import GHC.Generics++-- | Path substitution mode, used by @queryValidPaths@+data SubstituteMode+  = SubstituteMode_DoSubstitute+  | SubstituteMode_DontSubstitute+  deriving (Bounded, Eq, Generic, Enum, Ord, Show)

@@ -0,0 +1,10 @@+module System.Nix.Store.Remote.Types.SuccessCodeReply+  ( SuccessCodeReply(..)+  ) where++import GHC.Generics (Generic)++-- | Reply that checks an int success return value+data SuccessCodeReply = SuccessCodeReply+  deriving (Eq, Show, Generic)+

@@ -0,0 +1,11 @@+module System.Nix.Store.Remote.Types.TrustedFlag+  ( TrustedFlag(..)+  ) where++import GHC.Generics (Generic)++-- | Whether remote side trust us+data TrustedFlag+  = TrustedFlag_Trusted+  | TrustedFlag_NotTrusted+  deriving (Bounded, Eq, Generic, Enum, Ord, Show)

@@ -0,0 +1,17 @@+module System.Nix.Store.Remote.Types.Verbosity+  ( Verbosity(..)+  ) where++import GHC.Generics++-- | Logging verbosity+data Verbosity+  = Verbosity_Error+  | Verbosity_Warn+  | Verbosity_Notice+  | Verbosity_Info+  | Verbosity_Talkative+  | Verbosity_Chatty+  | Verbosity_Debug+  | Verbosity_Vomit+  deriving (Bounded, Eq, Enum, Generic, Ord, Show)

@@ -0,0 +1,27 @@+module System.Nix.Store.Remote.Types.WorkerMagic+  ( WorkerMagic(..)+  , workerMagicToWord64+  , word64ToWorkerMagic+  ) where++import Data.Word (Word64)+import GHC.Generics (Generic)++-- | WorkerMagic+--+-- Magic numbers exchange during handshake+data WorkerMagic+  = WorkerMagic_One+  | WorkerMagic_Two+  deriving (Eq, Generic, Ord, Show)++workerMagicToWord64 :: WorkerMagic -> Word64+workerMagicToWord64 = \case+  WorkerMagic_One -> 0x6e697863+  WorkerMagic_Two -> 0x6478696f++word64ToWorkerMagic :: Word64 -> Either String WorkerMagic+word64ToWorkerMagic = \case+  0x6e697863 -> Right WorkerMagic_One+  0x6478696f -> Right WorkerMagic_Two+  x -> Left $ "Invalid WorkerMagic: " ++ show x

@@ -0,0 +1,59 @@+module System.Nix.Store.Remote.Types.WorkerOp +  ( WorkerOp(..)+  ) where++import GHC.Generics (Generic)++-- | Worker opcode+--+-- This type has gaps filled in so that the GHC builtin+-- Enum instance lands on the right values.+data WorkerOp+  = WorkerOp_Reserved_0__ -- 0+  | WorkerOp_IsValidPath -- 1+  | WorkerOp_Reserved_2__ -- 2+  | WorkerOp_HasSubstitutes -- 3+  | WorkerOp_QueryPathHash -- 4 // obsolete+  | WorkerOp_QueryReferences --  5 // obsolete+  | WorkerOp_QueryReferrers --  6+  | WorkerOp_AddToStore --  7+  | WorkerOp_AddTextToStore --  8 // obsolete since 1.25, Nix 3.0. Use wopAddToStore+  | WorkerOp_BuildPaths --  9+  | WorkerOp_EnsurePath --  10 0xa+  | WorkerOp_AddTempRoot --  11 0xb+  | WorkerOp_AddIndirectRoot --  12 0xc+  | WorkerOp_SyncWithGC --  13 0xd+  | WorkerOp_FindRoots --  14 0xe+  | WorkerOp_Reserved_15__ -- 15 0xf+  | WorkerOp_ExportPath --  16 0x10 // obsolete+  | WorkerOp_Reserved_17__ -- 17 0x11+  | WorkerOp_QueryDeriver --  18 0x12 // obsolete+  | WorkerOp_SetOptions --  19 0x13+  | WorkerOp_CollectGarbage --  20 0x14+  | WorkerOp_QuerySubstitutablePathInfo --  21 0x15+  | WorkerOp_QueryDerivationOutputs --  22 0x16 // obsolete+  | WorkerOp_QueryAllValidPaths --  23 0x17+  | WorkerOp_QueryFailedPaths --  24 0x18+  | WorkerOp_ClearFailedPaths --  25 0x19+  | WorkerOp_QueryPathInfo --  26 0x1a+  | WorkerOp_ImportPaths --  27 0x1b // obsolete+  | WorkerOp_QueryDerivationOutputNames --  28 0x1c // obsolete+  | WorkerOp_QueryPathFromHashPart --  29 0x1d+  | WorkerOp_QuerySubstitutablePathInfos --  30 0x1e+  | WorkerOp_QueryValidPaths --  31 0x1f+  | WorkerOp_QuerySubstitutablePaths --  32 0x20+  | WorkerOp_QueryValidDerivers --  33 0x21+  | WorkerOp_OptimiseStore --  34 0x22+  | WorkerOp_VerifyStore --  35 0x23+  | WorkerOp_BuildDerivation --  36 0x24+  | WorkerOp_AddSignatures --  37 0x25+  | WorkerOp_NarFromPath --  38 0x26+  | WorkerOp_AddToStoreNar --  39 0x27+  | WorkerOp_QueryMissing --  40 0x28+  | WorkerOp_QueryDerivationOutputMap --  41 0x29+  | WorkerOp_RegisterDrvOutput --  42 0x2a+  | WorkerOp_QueryRealisation --  43 0x2b+  | WorkerOp_AddMultipleToStore --  44 0x2c+  | WorkerOp_AddBuildLog --  45 0x2d+  | WorkerOp_BuildPathsWithResults --  46 0x2e+  deriving (Bounded, Eq, Enum, Generic, Ord, Show, Read)

@@ -1,167 +0,0 @@-{-# language RecordWildCards     #-}-module System.Nix.Store.Remote.Util where--import           Prelude                 hiding ( putText )-import           Control.Monad.Except--import           Data.Binary.Get-import           Data.Binary.Put-import qualified Data.Text.Lazy.Encoding       as TL-import           Data.Time-import           Data.Time.Clock.POSIX-import qualified Data.ByteString.Char8         as BSC-import qualified Data.ByteString.Lazy          as BSL--import           Network.Socket.ByteString      ( recv-                                                , sendAll-                                                )--import           Nix.Derivation--import           System.Nix.Build-import           System.Nix.StorePath-import           System.Nix.Store.Remote.Binary-import           System.Nix.Store.Remote.Types--import qualified Data.HashSet-import qualified Data.Map--genericIncremental :: (MonadIO m) => m (Maybe ByteString) -> Get a -> m a-genericIncremental getsome parser = go decoder- where-  decoder = runGetIncremental parser-  go (Done _leftover _consumed x  ) = pure x-  go (Partial k                   ) = do-    chunk <- getsome-    go (k chunk)-  go (Fail _leftover _consumed msg) = error $ fromString msg--getSocketIncremental :: Get a -> MonadStore a-getSocketIncremental = genericIncremental sockGet8- where-  sockGet8 :: MonadStore (Maybe BSC.ByteString)-  sockGet8 = do-    soc <- asks storeSocket-    liftIO $ Just <$> recv soc 8--sockPut :: Put -> MonadStore ()-sockPut p = do-  soc <- asks storeSocket-  liftIO $ sendAll soc $ toStrict $ runPut p--sockGet :: Get a -> MonadStore a-sockGet = getSocketIncremental--sockGetInt :: Integral a => MonadStore a-sockGetInt = getSocketIncremental getInt--sockGetBool :: MonadStore Bool-sockGetBool = (== (1 :: Int)) <$> sockGetInt--sockGetStr :: MonadStore ByteString-sockGetStr = getSocketIncremental getByteStringLen--sockGetStrings :: MonadStore [ByteString]-sockGetStrings = getSocketIncremental getByteStrings--sockGetPath :: MonadStore StorePath-sockGetPath = do-  sd  <- getStoreDir-  pth <- getSocketIncremental (getPath sd)-  either-    throwError-    pure-    pth--sockGetPathMay :: MonadStore (Maybe StorePath)-sockGetPathMay = do-  sd  <- getStoreDir-  pth <- getSocketIncremental (getPath sd)-  pure $-    either-      (const Nothing)-      Just-      pth--sockGetPaths :: MonadStore StorePathSet-sockGetPaths = do-  sd <- getStoreDir-  getSocketIncremental (getPaths sd)--bsToText :: ByteString -> Text-bsToText = decodeUtf8--textToBS :: Text -> ByteString-textToBS = encodeUtf8--bslToText :: BSL.ByteString -> Text-bslToText = toText . TL.decodeUtf8--textToBSL :: Text -> BSL.ByteString-textToBSL = TL.encodeUtf8 . toLText--putText :: Text -> Put-putText = putByteStringLen . textToBSL--putTexts :: [Text] -> Put-putTexts = putByteStrings . fmap textToBSL--getPath :: FilePath -> Get (Either String StorePath)-getPath sd = parsePath sd <$> getByteStringLen--getPaths :: FilePath -> Get StorePathSet-getPaths sd =-  Data.HashSet.fromList . rights . fmap (parsePath sd) <$> getByteStrings--putPath :: StorePath -> Put-putPath = putByteStringLen . fromStrict . storePathToRawFilePath--putPaths :: StorePathSet -> Put-putPaths = putByteStrings . Data.HashSet.toList . Data.HashSet.map-  (fromStrict . storePathToRawFilePath)--putBool :: Bool -> Put-putBool True  = putInt (1 :: Int)-putBool False = putInt (0 :: Int)--getBool :: Get Bool-getBool = (== 1) <$> (getInt :: Get Int)--putEnum :: (Enum a) => a -> Put-putEnum = putInt . fromEnum--getEnum :: (Enum a) => Get a-getEnum = toEnum <$> getInt--putTime :: UTCTime -> Put-putTime = (putInt :: Int -> Put) . round . utcTimeToPOSIXSeconds--getTime :: Get UTCTime-getTime = posixSecondsToUTCTime <$> getEnum--getBuildResult :: Get BuildResult-getBuildResult =-  BuildResult-    <$> getEnum-    <*> (Just . bsToText <$> getByteStringLen)-    <*> getInt-    <*> getBool-    <*> getTime-    <*> getTime--putDerivation :: Derivation StorePath Text -> Put-putDerivation Derivation{..} = do-  flip putMany (Data.Map.toList outputs)-    $ \(outputName, DerivationOutput{..}) -> do-        putText outputName-        putPath path-        putText hashAlgo-        putText hash--  putMany putPath inputSrcs-  putText platform-  putText builder-  putMany putText args--  flip putMany (Data.Map.toList env)-    $ \(a1, a2) -> putText a1 *> putText a2

@@ -0,0 +1,26 @@+module DataSink++( DataSink(..)+, dataSinkResult+, dataSinkWriter+, newDataSink+)++where++import Data.ByteString (ByteString)++import Control.Monad.ST+import Data.STRef++-- | Basic data sink for testing+newtype DataSink = DataSink (STRef RealWorld ByteString)++newDataSink :: IO DataSink+newDataSink = DataSink <$> (stToIO . newSTRef) mempty++dataSinkWriter :: DataSink -> (ByteString -> IO())+dataSinkWriter (DataSink stref) chunk = stToIO (modifySTRef stref (chunk <>))++dataSinkResult :: DataSink -> IO ByteString+dataSinkResult (DataSink stref) = (stToIO . readSTRef) stref

@@ -0,0 +1,12 @@+module Main where++import qualified Test.Hspec+import qualified NixDaemonSpec++-- we run remote tests in+-- Linux namespaces to avoid interacting with systems store+main :: IO ()+main = do+  NixDaemonSpec.enterNamespaces+  Test.Hspec.hspec+    NixDaemonSpec.spec

@@ -0,0 +1,521 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns #-}++module NixDaemonSpec+  ( enterNamespaces+  , spec+  ) where++import Control.Exception (catch, SomeException)+import Control.Monad (forM_, unless, void)+import Control.Monad.Catch (MonadMask)+import Control.Monad.Conc.Class (MonadConc)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Crypto.Hash (SHA256)+import Data.Some (Some(Some))+import Data.Text (Text)+import Test.Hspec (ActionWith, Spec, SpecWith, around, describe, context)+import Test.Hspec.Expectations.Lifted+import Test.Hspec.Nix (forceRight)+import System.FilePath ((</>))+import System.Linux.Namespaces (Namespace(..), GroupMapping(..), UserMapping(..))+import System.Nix.Hash (HashAlgo(HashAlgo_SHA256))+import System.Nix.Build (BuildMode(..))+import System.Nix.DerivedPath (DerivedPath(..))+import System.Nix.StorePath (StoreDir(..), StorePath)+import System.Nix.StorePath.Metadata (Metadata(..))+import System.Nix.Store.Remote+import System.Nix.Store.Remote.Server (WorkerHelper)+import System.Process (CreateProcess(..), ProcessHandle)+import qualified Control.Concurrent+import qualified Control.Exception+import qualified Data.ByteString.Char8+import qualified Data.Either+import qualified Data.HashSet+import qualified Data.Map+import qualified Data.Set+import qualified Data.Text+import qualified Data.Text.Encoding+import qualified DataSink+import qualified SampleNar+import qualified System.Directory+import qualified System.Environment+import qualified System.IO.Temp+import qualified System.Linux.Namespaces+import qualified System.Nix.StorePath+import qualified System.Nix.Nar+import qualified System.Posix.User+import qualified System.Process+import qualified Test.Hspec++createProcessEnv+  :: FilePath+  -> CreateProcess+  -> IO ProcessHandle+createProcessEnv fp cp = do+  mPath         <- System.Environment.lookupEnv "PATH"++  (_, _, _, ph) <-+    System.Process.createProcess cp+      { cwd = Just fp+      , env = Just $ mockedEnv mPath fp+      }+  pure ph++mockedEnv+  :: Maybe String+  -> FilePath+  -> [(String, FilePath)]+mockedEnv mEnvPath fp =+  [ ("NIX_STORE_DIR"     , fp </> "store")+  , ("NIX_LOCALSTATE_DIR", fp </> "var")+  , ("NIX_LOG_DIR"       , fp </> "var" </> "log")+  , ("NIX_STATE_DIR"     , fp </> "var" </> "nix")+  , ("NIX_CONF_DIR"      , fp </> "etc")+  , ("HOME"              , fp </> "home")+--  , ("NIX_REMOTE", "daemon")+    ] <> foldMap (\x -> [("PATH", x)]) mEnvPath++waitSocket+  :: FilePath+  -> Int+  -> IO ()+waitSocket _  0 = fail "No socket"+waitSocket fp x = do+  ex <- System.Directory.doesFileExist fp+  unless ex $ do+    Control.Concurrent.threadDelay 100000+    waitSocket fp (x - 1)++writeConf :: FilePath -> IO ()+writeConf fp =+  writeFile fp $ unlines+    [ "build-users-group = "+    , "trusted-users = root"+    , "allowed-users = *"+    , "fsync-metadata = false"+    ]++{-+ - we run in user namespace as root but groups are failed+ - => build-users-group has to be empty but we still+ - get an error (maybe older nix-daemon)+ -+uid=0(root) gid=65534(nobody) groups=65534(nobody)++drwxr-xr-x 3 0 65534 60 Nov 29 05:53 store++accepted connection from pid 22959, user root (trusted)+error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e5616122/store': Invalid argument+-}++startDaemon+  :: FilePath -- ^ Temporary directory+  -> IO (ProcessHandle, StoreConnection)+startDaemon fp = do+  writeConf (fp </> "etc" </> "nix.conf")+  procHandle <-+    createProcessEnv+      fp+      $ System.Process.proc "nix-daemon" mempty++  waitSocket sockFp 30+  pure ( procHandle+       , StoreConnection_Socket+          $ StoreSocketPath sockFp+       )+ where+  sockFp = fp </> "var/nix/daemon-socket/socket"++enterNamespaces :: IO ()+enterNamespaces = do+  uid <- System.Posix.User.getEffectiveUserID+  gid <- System.Posix.User.getEffectiveGroupID++  System.Linux.Namespaces.unshare+    [User, Network, Mount]++  -- fmap our (parent) uid to root+  System.Linux.Namespaces.writeUserMappings+    Nothing+    [ UserMapping+        0    -- inside namespace+        uid  -- outside namespace+        1    --range+    ]++  -- fmap our (parent) gid to root group+  System.Linux.Namespaces.writeGroupMappings+    Nothing+    [ GroupMapping 0 gid 1 ]+    True++withNixDaemon'+  :: (FilePath -> StoreDir -> StoreConnection -> IO a)+  -> IO a+withNixDaemon' action =+  System.IO.Temp.withSystemTempDirectory "test-nix-store" $ \path -> do++    mapM_ (System.Directory.createDirectory . snd)+          (filter+            ((/= "NIX_REMOTE") . fst)+            $ mockedEnv Nothing path)++    ini <-+      createProcessEnv+        path+        $ System.Process.shell+            -- see long note above @startDaemon@+            "nix-store --init 2>&1 | grep -v 'error: changing ownership'"++    void $ System.Process.waitForProcess ini++    writeFile (path </> "dummy") "Hello World"++    System.Directory.setCurrentDirectory path+    let storeDir =+          StoreDir+          $ Data.ByteString.Char8.pack+          $ path </> "store"++    Control.Exception.bracket+      (startDaemon path)+      (System.Process.terminateProcess . fst)+      (action path storeDir . snd)++withNixDaemon+  :: ( MonadIO m+     , MonadMask m+     )+  => ((RemoteStoreT m a -> Run m a) -> IO a)+  -> IO a+withNixDaemon action =+  withNixDaemon' $ \_tmpPath storeDir storeConn ->+    action $ \(mstore :: RemoteStoreT m a) ->+      runStoreConnection storeConn+        ( setStoreDir storeDir+          >> mstore+        )++withManInTheMiddleNixDaemon+  :: forall m a+   . ( MonadIO m+     , MonadMask m+     , MonadConc m+     )+  => ((RemoteStoreT m a -> Run m a) -> IO a)+  -> IO a+withManInTheMiddleNixDaemon action =+  withNixDaemon' $ \tmpPath storeDir storeConn ->+  let+    sockFp2 = tmpPath </> "var/nix/daemon-socket/socket2"+    storeConn2 = StoreConnection_Socket $ StoreSocketPath sockFp2++    handler :: WorkerHelper m+    handler =+      runStoreConnection storeConn+      . (setStoreDir storeDir >>)++  in action $ \(mstore :: RemoteStoreT m a) ->+    runDaemonConnection handler+      (setStoreDir storeDir)+      storeConn2+      $ runStoreConnection storeConn2+          ( setStoreDir storeDir+            >> mstore+          )++checks+  :: ( Show a+     , Show b+     )+  => IO (a, b)+  -> (a -> Bool)+  -> IO ()+checks action check =+  action >>= (`Test.Hspec.shouldSatisfy` (check . fst))++it+  :: (Show a, Show b, Monad m)+  => String+  -> m c+  -> (a -> Bool)+  -> SpecWith (m () -> IO (a, b))+it name action check =+  Test.Hspec.it name $ \run -> run (void $ action) `checks` check++itRights+  :: ( Show a+     , Show b+     , Show c+     , Monad m+     )+  => String+  -> m d+  -> SpecWith (m () -> IO (Either a b, c))+itRights name action = it name action Data.Either.isRight++itLefts+  :: ( Show a+     , Show b+     , Show c+     , Monad m+     )+  => String+  -> m d+  -> SpecWith (m () -> IO (Either a b, c))+itLefts name action = it name action Data.Either.isLeft++sampleText :: Text+sampleText = "test"++withPath+  :: MonadRemoteStore m+  => (StorePath -> m a)+  -> m a+withPath action = do+  path <-+    addTextToStore+      (StoreText+        (forceRight $ System.Nix.StorePath.mkStorePathName "hnix-store")+        sampleText+      )+      mempty+      RepairMode_DontRepair+  action path++-- | dummy path, adds <tmp>/dummy with "Hello World" contents+dummy :: MonadRemoteStore m => m StorePath+dummy = do+  addToStore+    (forceRight $ System.Nix.StorePath.mkStorePathName "dummy")+    (System.Nix.Nar.dumpPath "dummy")+    FileIngestionMethod_Flat+    (Some HashAlgo_SHA256)+    RepairMode_DontRepair++invalidPath :: StorePath+invalidPath =+  let name = forceRight $ System.Nix.StorePath.mkStorePathName "invalid"+  in System.Nix.StorePath.unsafeMakeStorePath+      (System.Nix.StorePath.mkStorePathHashPart+        @SHA256+        "invalid")+      name++_withBuilder+  :: MonadRemoteStore m+  => (StorePath -> m a)+  -> m a+_withBuilder action = do+  path <-+    addTextToStore+      (StoreText+        (forceRight $ System.Nix.StorePath.mkStorePathName "builder")+        builderSh+      )+      mempty+      RepairMode_DontRepair+  action path++builderSh :: Text+builderSh = "declare -xpexport > $out"++spec :: Spec+spec = do+  describe "Remote store protocol" $ do+    describe "Direct"+      $ makeProtoSpec+          withNixDaemon+          SpecFlavor_Direct+    describe "MITM"+      $ makeProtoSpec+          withManInTheMiddleNixDaemon+          SpecFlavor_MITM++data SpecFlavor+  = SpecFlavor_Direct+  | SpecFlavor_MITM+  deriving (Eq, Ord, Show)++makeProtoSpec+  :: (ActionWith+       (RemoteStoreT IO () -> Run IO ())+       -> IO ()+     )+  -> SpecFlavor+  -> Spec+makeProtoSpec f flavor = around f $ do++  context "syncWithGC" $+    itRights "syncs with garbage collector" syncWithGC++  context "verifyStore" $ do+    itRights "check=False repair=False" $+      verifyStore+        CheckMode_DontCheck+        RepairMode_DontRepair+      `shouldReturn` False++    itRights "check=True repair=False" $+      verifyStore+        CheckMode_DoCheck+        RepairMode_DontRepair+      `shouldReturn` False++    --privileged+    itRights "check=True repair=True" $+      verifyStore+        CheckMode_DoCheck+        RepairMode_DoRepair+      `shouldReturn` False++  context "addTextToStore" $+    itRights "adds text to store" $ withPath pure++  context "isValidPath" $ do+    itRights "validates path" $ withPath $ \path -> do+      isValidPath path `shouldReturn` True++    itLefts "fails on invalid path" $ do+      setStoreDir (StoreDir "/asdf")+      isValidPath invalidPath++  context "queryAllValidPaths" $ do+    itRights "empty query" queryAllValidPaths+    itRights "non-empty query" $ withPath $ \path ->+      queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path]++  context "queryPathInfo" $+    itRights "queries path info" $ withPath $ \path -> do+      meta <- queryPathInfo path+      (metadataReferences <$> meta) `shouldBe` (Just mempty)++  context "ensurePath" $+    itRights "simple ensure" $ withPath ensurePath++  context "addTempRoot" $+    itRights "simple addition" $ withPath addTempRoot++  context "addIndirectRoot" $+    itRights "simple addition" $ withPath addIndirectRoot++  let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p]++  context "buildPaths" $ do+    itRights "build Normal" $ withPath $ \path -> do+      buildPaths (toDerivedPathSet path) BuildMode_Normal++    itRights "build Check" $ withPath $ \path -> do+      buildPaths (toDerivedPathSet path) BuildMode_Check++    itLefts "build Repair" $ withPath $ \path -> do+      buildPaths (toDerivedPathSet path) BuildMode_Repair++  context "roots" $ context "findRoots" $ do+    itRights "empty roots" (findRoots `shouldReturn` mempty)++    itRights "path added as a temp root" $ withPath $ \_ -> do+      let expectRoots =+            if flavor == SpecFlavor_MITM+            then 0 -- nested client closes its connection so temp root gets removed+            else 1+      roots <- findRoots+      roots `shouldSatisfy` ((== expectRoots) . Data.Map.size)++    itRights "indirect root" $ withPath $ \path -> do+      let expectRoots =+            if flavor == SpecFlavor_MITM+            then 1 -- nested client closes its connection so temp root gets removed+            else 2+      addIndirectRoot path+      roots <- findRoots+      roots `shouldSatisfy` ((== expectRoots) . Data.Map.size)++  context "optimiseStore" $ itRights "optimises" optimiseStore++  context "queryMissing" $+    itRights "queries" $ withPath $ \path -> do+      queryMissing (toDerivedPathSet path)+      `shouldReturn`+      Missing+        { missingWillBuild = mempty+        , missingWillSubstitute = mempty+        , missingUnknownPaths = mempty+        , missingDownloadSize = 0+        , missingNarSize = 0+        }++  context "addToStore" $+    itRights "adds file to store" $ do+      fp <-+        liftIO+        $ System.IO.Temp.writeSystemTempFile+            "addition"+            "yolo"++      addToStore+        (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition")+        (System.Nix.Nar.dumpPath fp)+        FileIngestionMethod_Flat+        (Some HashAlgo_SHA256)+        RepairMode_DontRepair++  context "with dummy" $ do+    itRights "adds dummy" dummy++    itRights "valid dummy" $ do+      path <- dummy+      isValidPath path `shouldReturn` True++  context "collectGarbage" $ do+    itRights "deletes a specific path from the store" $ withPath $ \path -> do+        -- clear temp gc roots so the delete works. restarting the nix daemon should also do this...+        storeDir <- getStoreDir+        let tempRootsDir = Data.Text.unpack $ mconcat [ Data.Text.Encoding.decodeUtf8 (unStoreDir storeDir), "/../var/nix/temproots/" ]+        liftIO $ do+          tempRootList <-+            System.Directory.listDirectory tempRootsDir+          forM_ tempRootList $ \entry -> do+            System.Directory.removeFile+              $ mconcat [ tempRootsDir, "/", entry ]+            -- for MITM, the temp root will get deleted+            -- by the daemon as our nested client exists+            -- but the listDirectory might still see it+            -- causing TOC/TOU flakiness+            `catch` (\(_e :: SomeException) -> pure ())++        GCResult{..} <-+          collectGarbage+            GCOptions+              { gcOptionsOperation = GCAction_DeleteSpecific+              , gcOptionsIgnoreLiveness = False+              , gcOptionsPathsToDelete = Data.HashSet.fromList [path]+              , gcOptionsMaxFreed = maxBound+              }+        gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path]+        gcResultBytesFreed `shouldBe` 4++  context "addToStoreNar" $ do+    itRights "adds nar file" $ do+      unless (flavor == SpecFlavor_MITM) $ do+        sampleNar@SampleNar.SampleNar{..} <- liftIO SampleNar.sampleNar0+        dataSource <- liftIO $ SampleNar.buildDataSource sampleNar+        addToStoreNar sampleNar_storePath sampleNar_metadata RepairMode_DontRepair CheckMode_DontCheck dataSource++        meta <- queryPathInfo sampleNar_storePath+        (metadataDeriverPath =<< meta) `shouldBe` metadataDeriverPath sampleNar_metadata++  context "narFromPath" $ do+    itRights "downloads nar file" $ do+      unless (flavor == SpecFlavor_MITM) $ do+        withPath $ \path -> do+          maybeMetadata <- queryPathInfo path+          case maybeMetadata of+            Just Metadata{metadataNarBytes=Just narBytes} -> do+              dataSink <- liftIO DataSink.newDataSink+              narFromPath path narBytes (DataSink.dataSinkWriter dataSink)+              narData <- liftIO $ DataSink.dataSinkResult dataSink+              expectedNarData <- liftIO $ SampleNar.encodeNar (Data.Text.Encoding.encodeUtf8 sampleText)+              narData `shouldBe` expectedNarData+            _ -> expectationFailure "missing metadata or narBytes"