packages feed

hnix-store-remote 0.6.0.0 → 0.8.0.0

raw patch · 53 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,92 @@+# [0.8.0.0](https://github.com/haskell-nix/hnix-store/compare/remote-0.7.0.0...remote-0.8.0.0) 2026-10-21++* Changes:+   * Make `putS` infallible (`a -> PutM ()` instead of `a -> t PutM ()`)+   * Remove `SerialT` reader monad; `StoreDir` and `ProtoVersion` are now passed as explicit parameters+   * Add `AlmostPrism` type and rewrite `mapPrismSerializer`+   * Add `depTup`, `mapS'`, `maybeByteString` combinators to `Data.Serializer`+   * Update `buildResult` serializer for new `BuildSuccess`/`BuildFailure` types+   * Update `buildTraceKeyTyped` serializer for `StorePath`-based `BuildTraceKey`+   * New dependency: `mmorph`+   * Protocol version updated to 1.38+   * `ProtoVersion` now includes `protoVersion_features :: Set ProtoFeature` for feature negotiation+   * Feature negotiation during handshake (client and server) when both sides >= 1.38+   * `PartialOrd` replaces `Ord` on `ProtoVersion` (from `lattices`)+   * New dependency: `lattices`+   * Support for the `builder-rpc-v0` interface+     * New `SubmitOutput` (1000) and `AddToStoreScanning` (1001) operations, with `submitOutput` and `addToStoreScanning` client functions+     * `builderRpcV0` constant for the pinned profile, set it as the client's `ProtoVersion` before the handshake+     * `WorkerOp` wire mapping now goes through `workerOpToWord64` and `word64ToWorkerOp` since opcodes are no longer contiguous+     * New `singleDerivedPath` serializer++# [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
− ChangeLog.md 
@@ -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.
+ README.lhs view
@@ -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+```
README.md view
@@ -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 ```
+ app/BuildDerivation.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE LambdaCase #-}+module Main where++import Data.Default.Class (Default(def))++import Data.Text qualified+import System.Environment qualified+import System.Nix.Build qualified+import System.Nix.StorePath qualified+import System.Nix.Store.Remote qualified++main :: IO ()+main = System.Environment.getArgs >>= \case+  [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"+
hnix-store-remote.cabal view
@@ -1,23 +1,52 @@ cabal-version:       2.2 name:                hnix-store-remote-version:             0.6.0.0+version:             0.8.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+    , ImportQualifiedPost+    , GADTs+    , RecordWildCards+    , ScopedTypeVariables+    , StandaloneDeriving+    , TypeApplications+    , TypeOperators+    , TypeSynonymInstances+    , InstanceSigs+    , KindSignatures+    , MultiParamTypeClasses+    , TupleSections+    , LambdaCase+    , BangPatterns+    , ViewPatterns+  default-language: Haskell2010  flag io-testsuite   default:@@ -26,117 +55,179 @@     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.9 && <0.10+    , hnix-store-json >= 0.2+    , hnix-store-nar >= 0.1+    , hnix-store-tests >= 0.2+    , hnix-store-aterm+    , 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+    , lattices+    , mmorph     , 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+executable build-derivation   import: commons+  if !flag(build-derivation)+    buildable: False+  build-depends:+      base >=4.12 && <5+    , hnix-store-core+    , hnix-store-remote+    , data-default-class+    , text+  main-is: BuildDerivation.hs+  hs-source-dirs:      app+  ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N" -  if !flag(io-testsuite)+executable remote-readme+  import: commons+  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+  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+    , hnix-store-aterm     , containers-    , cryptonite+    , crypton+    , some > 1.0.5 && < 2+    , hspec+    , QuickCheck+    , time+    , transformers++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+    , 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
+ src/Data/Serializer.hs view
@@ -0,0 +1,230 @@+{-# 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+  -- * From Get/Put, Serialize+  , lift2+  , liftSerialize+  -- * Combinators+  , AlmostPrism(..)+  , maybeAlmostPrism+  , mapIsoSerializer+  , mapPrismSerializer+  , tup+  , depTup+  -- * Utility+  , GetSerializerError(..)+  , transformGetError+  -- * Re-exports+  , Get+  , PutM+  ) where++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif+import Control.Monad.Morph+import Control.Monad.Trans.Identity (IdentityT, runIdentityT)+import Data.ByteString (ByteString)+import Data.Functor.Identity+import Data.Serialize (Serialize)+import Data.Serialize qualified+import Data.Serialize.Get (Get, runGet)+import Data.Serialize.Put (Putter, PutM, runPutM)+++-- * 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 -> PutM ()+  }++-- ** Runners++-- | Runner for putS of @Serializer@+runPutS+  :: Serializer t a        -- ^ Serializer+  -> a                     -- ^ Value to (out)put+  -> ByteString+runPutS s = snd . runPutM . putS s++-- | 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++-- * 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 = 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+  }++data AlmostPrism t a b = AlmostPrism+  { _almostPrism_get :: a -> t Identity b+  -- ^ Map over @getS@+  , _almostPrism_put :: b -> a+  -- ^ Map over @putS@+  }++maybeAlmostPrism+  :: Applicative (t Identity)+  => AlmostPrism t a b+  -> AlmostPrism t (Maybe a) (Maybe b)+maybeAlmostPrism ap = AlmostPrism+  { _almostPrism_get = traverse $ _almostPrism_get ap+  , _almostPrism_put = fmap $ _almostPrism_put ap+  }++-- | Map over @Serializer@ where @getS@+-- can return @Either@+mapPrismSerializer+  :: ( Monad (t Get)+     , MFunctor t+     )+  => AlmostPrism t a b+  -> Serializer t a+  -> Serializer t b+mapPrismSerializer p s = Serializer+  { getS = hoist generalize . _almostPrism_get p =<< getS s+  , putS = putS s . _almostPrism_put p+  }++-- | 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+  }++-- | Dependent tuple combinator+depTup+  :: ( Monad (t Get)+     , Monad (t PutM)+     )+  => Serializer t a+  -> (a -> Serializer t b)+  -> Serializer t (a, b)+depTup sa sb = Serializer+  { getS = do+    a <- getS sa+    b <- getS $ sb a+    pure (a, b)+  , putS = \(x, y) -> do+      putS sa x+      putS (sb x) y+  }++-- * Utilities++-- | Wrapper for both GetS errors+--+--   * 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
+ src/Data/Serializer/Example.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.Serializer.Example+  (+  -- * Simple protocol+    OpCode(..)+  , Cmd(..)+  -- * Cmd Serializer+  , cmdS+  -- * Runners+  , runG+  , runP+  -- * Custom errors+  , MyGetError(..)+  -- ** Erroring variants of cmdS+  -- *** getS with throwError and MyGetError+  , cmdSGetError+  -- *** getS with fail+  , cmdSGetFail+  -- * Elaborate+  , cmdSRest+  , runGRest+  , runPRest+  ) where++import Control.Monad.Except (MonadError, throwError)+import Control.Monad.Reader (MonadReader)+import Control.Monad.State (MonadState)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Monad.Trans.State (StateT, runStateT)+import Data.Bifunctor (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+  )+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 = putEnum+  }++-- * Cmd Serializer++-- | @Cmd@ @Serializer@+cmdS+  :: forall t+  . ( MonadTrans t+    , Monad (t Get)+    )+  => Serializer t (Some Cmd)+cmdS = Serializer+  { getS = getS opcode >>= \case+      OpCode_Int -> Some . Cmd_Int <$> lift getInt8+      OpCode_Bool -> Some . Cmd_Bool <$> lift getBool+  , putS = \case+      Some (Cmd_Int i) -> putS (opcode @t) OpCode_Int >> putInt8 i+      Some (Cmd_Bool b) -> putS (opcode @t) OpCode_Bool >> 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+  -> ByteString+runP = runPutS++-- * Custom errors++data MyGetError+  = MyGetError_Example+  deriving (Eq, Show)++-- ** Erroring variants of cmdS++-- *** 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 @(ExceptT MyGetError)+  }++-- *** getS with fail++cmdSGetFail+  :: forall t+  .  ( 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 @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+  -> a+  -> ByteString+runPRest = runPutS++cmdSRest+  :: forall t e+  .  t ~ REST Bool e Int+  => Bool+  -> Serializer t (Some Cmd)+cmdSRest isTrue = Serializer+  { getS = getS opcode >>= \case+      OpCode_Int -> do+        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 @t) OpCode_Int+        if isTrue+        then putInt8 (i - 1)+        else putInt8 i+      Some (Cmd_Bool b) -> putS (opcode @t) OpCode_Bool >> 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
src/System/Nix/Store/Remote.hs view
@@ -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--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 qualified Data.Binary.Put-import qualified Data.Map.Strict-import qualified Data.Set--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+  -- * Compat+  , MonadStore+  -- * Runners+  , runStore+  , runStoreConnection+  , runStoreSocket+  -- ** Daemon+  , runDaemon+  , runDaemonConnection+  , justdoit+  ) where -  _sigStrings      <- fmap bsToText <$> sockGetStrings-  caString         <- sockGetStr+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 (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 -  let-      -- XXX: signatures need pubkey from config-      sigs = Data.Set.empty+import Control.Monad.Catch qualified+import Network.Socket qualified+-- see TODO bellow+--import System.Directory qualified -      contentAddressableAddress =-        case-          System.Nix.Store.Remote.Parsers.parseContentAddressableAddress caString-          of-          Left  e -> error $ fromString e-          Right x -> Just x+-- wip justdoit+import System.Nix.StorePath (StorePath)+import System.Nix.StorePath qualified -      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)
+ src/System/Nix/Store/Remote/Arbitrary.hs view
@@ -0,0 +1,149 @@+-- 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.Derivation (Derivation'(..))+import System.Nix.StorePath (StorePath(..))+import System.Nix.Store.Types (RepairMode(..))+import System.Nix.Store.Remote.Types++import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum, 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++-- Custom instance: major is always 1 (the only real protocol major version),+-- features are always empty (features are exchanged separately, not in wire format).+instance Arbitrary ProtoVersion where+  arbitrary = ProtoVersion 1 <$> arbitrary <*> pure mempty++instance Arbitrary ProtoFeature where+  arbitrary = arbitraryBoundedEnum++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{..}++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 <*> arbitrary <*> arbitrary)+    , Some <$> (AddToStoreScanning <$> arbitrary <*> arbitrary <*> arbitrary)+    , Some <$> (AddTextToStore <$> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair)+    , Some <$> (AddSignatures <$> arbitrary <*> arbitrary)+    , Some . AddIndirectRoot  <$> arbitrary+    , Some . AddTempRoot <$> arbitrary+    , Some <$> (BuildPaths <$> arbitrary <*> arbitrary)+    , do+        path <- arbitrary+        drv <- arbitrary+        buildMode' <- arbitrary+        -- Ensure store path name matches derivation name (helps with length issues)+        let path' = path { storePathName = name drv }+        pure $ Some (BuildDerivation path' drv buildMode')+    , Some . CollectGarbage <$> arbitrary+    , Some . EnsurePath <$> arbitrary+    , pure $ Some FindRoots+    , 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+    , Some <$> (SubmitOutput <$> arbitrary <*> arbitrary)+    , 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
− src/System/Nix/Store/Remote/Binary.hs 
@@ -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
− src/System/Nix/Store/Remote/Builders.hs 
@@ -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
+ src/System/Nix/Store/Remote/Client.hs view
@@ -0,0 +1,344 @@+module System.Nix.Store.Remote.Client+  ( addToStore+  , addToStoreNar+  , addToStoreScanning+  , addTextToStore+  , addSignatures+  , addTempRoot+  , addIndirectRoot+  , buildPaths+  , buildDerivation+  , collectGarbage+  , ensurePath+  , findRoots+  , isValidPath+  , narFromPath+  , queryValidPaths+  , queryAllValidPaths+  , querySubstitutablePaths+  , queryPathInfo+  , queryReferrers+  , queryValidDerivers+  , queryDerivationOutputs+  , queryDerivationOutputNames+  , queryPathFromHashPart+  , queryMissing+  , optimiseStore+  , submitOutput+  , 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.Derivation.Traditional qualified+import System.Nix.Derivation.ATerm qualified+import System.Nix.DerivedPath (DerivedPath, SingleDerivedPath)+import System.Nix.Hash (HashAlgo(..))+import System.Nix.Nar (NarSource)+import System.Nix.OutputName (OutputName)+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.ProtoVersion (ProtoFeature(..), hasFeature)+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.ContentAddress (ContentAddressMethod)+import System.Nix.Store.Types (RepairMode(..))++import Control.Monad.IO.Class qualified+import Data.Attoparsec.Text qualified+import Data.Text.IO qualified+import System.Nix.Derivation qualified+import System.Nix.StorePath qualified++-- | Add `NarSource` to the store+addToStore+  :: MonadRemoteStore m+  => StorePathName        -- ^ Name part of the newly created `StorePath`+  -> NarSource IO         -- ^ Provide nar stream+  -> ContentAddressMethod -- ^ Content addressing method+  -> Some HashAlgo        -- ^ Hashing algorithm+  -> Set StorePath        -- ^ References+  -> RepairMode           -- ^ Whether to overwrite an existing valid path, repairing corruption.+                          --   Sent to the daemon as part of the request since the 1.25 wire format.+  -> m StorePath+addToStore name source method hashAlgo refs repair = do+  setNarSource source+  doReq (AddToStore name method hashAlgo refs repair)++-- | Add `NarSource` to the store, letting the daemon scan the+-- contents for references instead of declaring them.+--+-- Only valid on connections where @add-to-store-scanning@ was+-- negotiated, i.e. inside a derivation build with the+-- @recursive-nix@ or @builder-rpc-v0@ system feature.+addToStoreScanning+  :: MonadRemoteStore m+  => StorePathName        -- ^ Name part of the newly created `StorePath`+  -> NarSource IO         -- ^ Provide nar stream+  -> ContentAddressMethod -- ^ Content addressing method+  -> Some HashAlgo        -- ^ Hashing algorithm+  -> m StorePath+addToStoreScanning name source method hashAlgo = do+  requireProtoFeature ProtoFeature_AddToStoreScanning+  setNarSource source+  doReq (AddToStoreScanning name method hashAlgo)++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.ATerm.parseTraditionalDerivation sd) drvContents of+      Left e -> throwError $ RemoteStoreError_DerivationParse e+      Right drv -> do+        let name = System.Nix.StorePath.storePathName sp+        outputs <- case+          System.Nix.Derivation.toSpecificOutputs sd name $+            System.Nix.Derivation.Traditional.anonOutputs drv+          of+           Nothing -> throwError $ RemoteStoreError_DerivationParse "TODO get error"+           Just os -> pure os+        let drv' = System.Nix.Derivation.Traditional.withName name $+              drv+                { System.Nix.Derivation.Traditional.anonOutputs = outputs+                , System.Nix.Derivation.Traditional.anonInputs =+                    System.Nix.Derivation.Traditional.traditionalSrcs+                      (System.Nix.Derivation.Traditional.anonInputs drv)+                }+        doReq (BuildDerivation sp drv' mode)++-- | Build paths if they are an actual derivations.+--+-- 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++-- | Register a store object as an output of the currently running+-- derivation.+--+-- Only valid on connections where @submit-output@ was negotiated,+-- i.e. inside a derivation build with the @builder-rpc-v0@ system+-- feature.+submitOutput+  :: MonadRemoteStore m+  => SingleDerivedPath+  -> OutputName+  -> m ()+submitOutput path output = do+  requireProtoFeature ProtoFeature_SubmitOutput+  void $ doReq (SubmitOutput path output)++syncWithGC+  :: MonadRemoteStore m+  => m ()+syncWithGC = (void . doReq) SyncWithGC++-- | Fail early with a clear error instead of letting the daemon+-- reject the opcode.+requireProtoFeature+  :: MonadRemoteStore m+  => ProtoFeature+  -> m ()+requireProtoFeature f = do+  pv <- getProtoVersion+  Control.Monad.when+    (not $ hasFeature f pv)+    $ throwError $ RemoteStoreError_ProtocolFeatureNotNegotiated f++verifyStore+  :: MonadRemoteStore m+  => CheckMode+  -> RepairMode+  -> m Bool+verifyStore check repair = doReq (VerifyStore check repair)
+ src/System/Nix/Store/Remote/Client/Core.hs view
@@ -0,0 +1,279 @@+module System.Nix.Store.Remote.Client.Core+  ( Run+  , greetServer+  , doReq+  ) where++import Algebra.PartialOrd (leq)+import Control.Monad (unless, when)+import Control.Monad.Except (throwError)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Bits (shiftR)+import Data.ByteString (ByteString)+import Data.DList (DList)+import Data.Set qualified+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+  , protoFeatures+  , protoVersion+  , validPathInfo+  , 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(..), minVersionNumber)+import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))+import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..))+import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))++import Data.ByteString qualified+import Network.Socket.ByteString qualified++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+    storeDir <- getStoreDir+    pv <- getProtoVersion+    sockPutS+      (mapErrorS+        RemoteStoreError_SerializerRequest+          (storeRequest storeDir pv)+      )+      (Some x)++    case x of+      AddToStore {} -> do+        ms <- takeNarSource+        soc <- getStoreSocket+        case ms of+          Just (stream :: NarSource IO) ->+            liftIO $ writeFramedNarSource stream soc+          Nothing ->+            throwError+              RemoteStoreError_NoNarSourceProvided+        processOutput+        -- New protocol returns ValidPathInfo (path + metadata)+        (path, _metadata) <- sockGetS+          $ mapErrorS RemoteStoreError_SerializerGet+          $ validPathInfo storeDir+        pure path++      AddToStoreScanning {} -> do+        ms <- takeNarSource+        soc <- getStoreSocket+        case ms of+          Just (stream :: NarSource IO) ->+            liftIO $ writeFramedNarSource stream soc+          Nothing ->+            throwError+              RemoteStoreError_NoNarSourceProvided+        processOutput+        (path, _metadata) <- sockGetS+          $ mapErrorS RemoteStoreError_SerializerGet+          $ validPathInfo storeDir+        pure path++      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 = do+      storeDir <- getStoreDir+      pv <- getProtoVersion+      sockGetS+          (mapErrorS RemoteStoreError_SerializerReply+            $ getReplyS @a storeDir pv+          )++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++-- | Write a NarSource as framed data to a socket.+-- Each chunk of NAR data is prefixed with its length as a+-- little-endian u64, terminated by a zero-length frame.+writeFramedNarSource :: NarSource IO -> Socket -> IO ()+writeFramedNarSource narSource sock = do+  narSource sendChunk+  sendWord64le sock 0 -- terminator+  where+    sendChunk :: ByteString -> IO ()+    sendChunk bs = do+      let len = Data.ByteString.length bs+      when (len > 0) $ do+        sendWord64le sock (fromIntegral len)+        Network.Socket.ByteString.sendAll sock bs++    sendWord64le :: Socket -> Word64 -> IO ()+    sendWord64le s w =+      Network.Socket.ByteString.sendAll s+        $ Data.ByteString.pack+            [ fromIntegral (shiftR w (i * 8))+            | i <- [0..7]+            ]++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 (not (ProtoVersion 1 37 mempty `leq` daemonVersion))+    $ throwError RemoteStoreError_ClientVersionTooOld++  pv <- getProtoVersion+  sockPutS protoVersion pv++  let leastCommonVersion = minVersionNumber daemonVersion pv++  -- Feature exchange (>= 1.38)+  negotiatedFeatures <- if ProtoVersion 1 38 mempty `leq` leastCommonVersion+    then do+      sockPutS+        (mapErrorS RemoteStoreError_SerializerPut protoFeatures)+        (protoVersion_features pv)+      daemonFeatures <- sockGetS+        $ mapErrorS RemoteStoreError_SerializerGet protoFeatures+      pure $ Data.Set.intersection daemonFeatures (protoVersion_features pv)+    else pure mempty++  let leastCommonVersionWithFeatures = leastCommonVersion { protoVersion_features = negotiatedFeatures }++  setProtoVersion leastCommonVersionWithFeatures++  -- postHandshake: affinity (obsolete), reserveSpace (obsolete)+  sockPutS int (0 :: Int) -- affinity, obsolete+  sockPutS (mapErrorS RemoteStoreError_SerializerPut bool) False -- reserveSpace, obsolete++  -- If we were buffering I/O, we would flush the output here.++  daemonNixVersion <- Just <$>+    sockGetS (mapErrorS RemoteStoreError_SerializerGet text)++  remoteTrustsUs <-+    sockGetS (mapErrorS RemoteStoreError_SerializerHandshake trustedFlag)++  processOutput++  pure ClientHandshakeOutput+    { clientHandshakeOutputNixVersion = daemonNixVersion+    , clientHandshakeOutputTrust = remoteTrustsUs+    , clientHandshakeOutputLeastCommonVersion = leastCommonVersionWithFeatures+    , clientHandshakeOutputServerVersion = daemonVersion+    }
src/System/Nix/Store/Remote/Logger.hs view
@@ -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, runExceptT)+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 Control.Monad qualified+import Data.Serialize.Get qualified+import Data.Serializer qualified+import Network.Socket.ByteString qualified -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+      (runExceptT $ Data.Serializer.getS $ logger protoVersion) -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
+ src/System/Nix/Store/Remote/MonadStore.hs view
@@ -0,0 +1,391 @@+{-# 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, ErrorInfo)+import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoFeature, ProtoVersion)+import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..))++import Data.DList qualified++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 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_ProtocolFeatureNotNegotiated ProtoFeature+  | 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
− src/System/Nix/Store/Remote/Parsers.hs 
@@ -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 (/= ':')
− src/System/Nix/Store/Remote/Protocol.hs 
@@ -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)
+ src/System/Nix/Store/Remote/Serializer.hs view
@@ -0,0 +1,1608 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-|+Description : NixSerializer+Copyright   : (c) John Ericson, 2023+                  Sorki, 2023+|-}++module System.Nix.Store.Remote.Serializer+  (+  -- * NixSerializer+    NixSerializer+  , mapErrorS+  -- * Errors+  , SError(..)+  -- ** Runners+  , runExceptT+  , runG+  , runP+  -- * Primitives+  , int+  , bool+  , byteString+  , enum+  , text+  , maybeText+  -- * UTCTime+  , time+  -- * Combinators+  , list+  , set+  , hashSet+  , mapS+  , mapS'+  , vector+  , json+  -- * ProtoVersion+  , protoVersion+  , protoFeature+  , protoFeatures+  -- * StorePath+  , storePath+  , maybePath+  , storePathHashPart+  , storePathName+  -- * Metadata+  , pathMetadata+  , validPathInfo+  -- * OutputName+  , outputName+  -- * Signatures+  , signature+  , narSignature+  -- * Some HashAlgo+  , someHashAlgo+  -- * Digest+  , digest+  -- * DSum HashAlgo Digest+  , namedDigest+  -- * Derivation+  , basicDerivation+  -- * Derivation+  , derivedPath+  , singleDerivedPath+  -- * Build+  , buildMode+  -- * Logger+  , LoggerSError(..)+  , activityID+  , maybeActivity+  , activity+  , activityResult+  , field+  , trace+  , errorInfo+  , loggerOpCode+  , logger+  , verbosity+  -- * Handshake+  , HandshakeSError(..)+  , workerMagic+  , trustedFlag+  -- * Worker protocol+  , storeText+  , workerOp+  -- ** Request+  , RequestSError(..)+  , storeRequest+  -- ** Reply+  , ReplySError(..)+  , opSuccess+  , noop+  -- *** Realisation+  , realisation+  -- *** BuildResult+  , buildResult+  -- *** GCResult+  , gcResult+  -- *** GCResult+  , gcRoot+  -- *** Missing+  , missing+  -- *** Maybe (Metadata StorePath)+  , maybePathMetadata+  ) where+++import Control.Monad qualified+import Control.Monad.Except (MonadError, throwError, )+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Except (ExceptT(..), runExceptT, withExceptT)+import Crypto.Hash (Digest, HashAlgorithm, SHA256)+import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson qualified+import Data.Attoparsec.Text qualified+import Data.Bifunctor qualified+import Data.Bits qualified+import Data.ByteString (ByteString)+import Data.ByteString qualified+import Data.ByteString.Char8 qualified+import Data.ByteString.Lazy qualified+import Data.Dependent.Sum (DSum((:=>)))+import Data.Fixed (Uni)+import Data.Functor.Identity+import Data.HashSet (HashSet)+import Data.HashSet qualified+import Data.Hashable (Hashable)+import Data.Map (Map)+import Data.Map.Strict qualified+import Data.Maybe qualified+import Data.Serialize.Get qualified+import Data.Serialize.Put qualified+import Data.Serializer+import Data.Set (Set)+import Data.Set qualified+import Data.Some (Some(Some))+import Data.Some qualified+import Data.Text (Text)+import Data.Text qualified+import Data.Text.Encoding qualified+import Data.Text.Lazy qualified+import Data.Text.Lazy.Builder (Builder)+import Data.Text.Lazy.Builder qualified+import Data.Time (NominalDiffTime, UTCTime)+import Data.Time.Clock.POSIX qualified+import Data.Vector (Vector)+import Data.Vector qualified+import Data.Word (Word8, Word32, Word64)+import GHC.Generics (Generic)+import System.Nix.Base (BaseEncoding(Base16, NixBase32))+import System.Nix.Base qualified+import System.Nix.Build (BuildMode, BuildResult(..), BuildSuccess(..), BuildFailure(..), BuildSuccessStatus(..), BuildFailureStatus(..))+import System.Nix.ContentAddress (ContentAddress, methodAlgoBuilder, methodAlgoParser)+import System.Nix.ContentAddress qualified+import System.Nix.Derivation.Traditional+import System.Nix.Derivation+import System.Nix.DerivedPath (DerivedPath(..), SingleDerivedPath(..), ParseOutputsError)+import System.Nix.DerivedPath qualified+import System.Nix.Hash (HashAlgo(..))+import System.Nix.Hash qualified+import System.Nix.JSON ()+import System.Nix.OutputName (OutputName)+import System.Nix.OutputName qualified+import System.Nix.Realisation (Realisation(..))+import System.Nix.Signature (Signature, NamedSignature)+import System.Nix.Signature qualified+import System.Nix.Store.Remote.Types+import System.Nix.Store.Types (RepairMode(..))+import System.Nix.StorePath (StoreDir, InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName)+import System.Nix.StorePath qualified+import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..))++mapErrorS+  :: (e -> e')+  -> NixSerializer e a+  -> NixSerializer e' a+mapErrorS f s = Serializer+  { getS = withExceptT f $ getS s+  , putS = putS s+  }++-- * NixSerializer++type NixSerializer e = Serializer (ExceptT e)++-- * Errors++data SError+  = SError+  | SError_BadPadding+      { badPaddingStr :: ByteString+      , badPaddingLen :: Int+      , badPaddingPads :: [Word8]+      }+  | SError_ContentAddress String+  | SError_DerivedPath ParseOutputsError+  | SError_Digest String+  | SError_EnumOutOfMinBound Int+  | SError_EnumOutOfMaxBound Int+  | SError_HashAlgo String+  | SError_IllegalBool Word64+  | SError_InvalidNixBase32+  | SError_JSONDecoding String+  | SError_NarHashMustBeSHA256+  | SError_Name InvalidNameError+  | SError_Path InvalidPathError+  | SError_Signature String+  | SError_SingleDerivedPathInvalidTag Word64+  | SError_UnknownProtoFeature Text+  | SError_InvalidWorkerOp Word64+  deriving (Eq, Generic, Show)+++-- ** Runners++runG+  :: NixSerializer e a+  -> ByteString+  -> Either (GetSerializerError e) a+runG serializer =+    transformGetError+  . runGetS+      serializer+      (runExceptT)++runP+  :: NixSerializer e a+  -> a+  -> ByteString+runP = runPutS++-- * Primitives++int :: Integral a => NixSerializer e a+int = Serializer+  { getS = fromIntegral <$> lift Data.Serialize.Get.getWord64le+  , putS = Data.Serialize.Put.putWord64le . fromIntegral+  }++bool :: NixSerializer 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 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+      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+        (Data.Serialize.Put.putWord8 0)++maybeByteString :: NixSerializer SError (Maybe ByteString)+maybeByteString = mapIsoSerializer+  (\case+    t | Data.ByteString.null t -> Nothing+    t | otherwise -> Just t+  )+  (Data.Maybe.fromMaybe mempty)+  byteString++-- | Utility toEnum version checking bounds using Bounded class+toEnumCheckBoundsM+  :: 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 SError a+enum = Serializer+  { getS = getS int >>= toEnumCheckBoundsM+  , putS = putS int . fromEnum+  }++text :: NixSerializer SError Text+text = mapIsoSerializer+  Data.Text.Encoding.decodeUtf8+  Data.Text.Encoding.encodeUtf8+  byteString++-- TODO Parser Builder+_textBuilder :: NixSerializer SError Builder+_textBuilder = Serializer+  { getS = Data.Text.Lazy.Builder.fromText <$> getS text+  , putS = putS text . Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText+  }++maybeText :: NixSerializer SError (Maybe Text)+maybeText = mapIsoSerializer+  (\case+    t | Data.Text.null t -> Nothing+    t | otherwise -> Just t+  )+  (Data.Maybe.fromMaybe mempty)+  text++-- * UTCTime++time :: NixSerializer 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 e a+  -> NixSerializer 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 e a+  -> NixSerializer e (Set a)+set =+  mapIsoSerializer+    Data.Set.fromList+    Data.Set.toList+  . list++hashSet+  :: ( Eq a+     , Hashable a+     )+  => NixSerializer e a+  -> NixSerializer e (HashSet a)+hashSet =+  mapIsoSerializer+    Data.HashSet.fromList+    Data.HashSet.toList+  . list++mapS'+  :: Ord k+  => NixSerializer e (k, v)+  -> NixSerializer e (Map k v)+mapS' kv =+  mapIsoSerializer+    Data.Map.Strict.fromList+    Data.Map.Strict.toList+  $ list+  $ kv++mapS+  :: Ord k+  => NixSerializer e k+  -> NixSerializer e v+  -> NixSerializer e (Map k v)+mapS k v = mapS' $ tup k v++vector+  :: Ord a+  => NixSerializer e a+  -> NixSerializer e (Vector a)+vector =+  mapIsoSerializer+    Data.Vector.fromList+    Data.Vector.toList+  . list++json+  :: ( FromJSON a+     , ToJSON a+     )+  => NixSerializer SError a+json = mapPrismSerializer jsonP+    $ mapIsoSerializer+        Data.ByteString.Lazy.fromStrict+        Data.ByteString.Lazy.toStrict+        byteString++jsonP+  :: ( FromJSON a+     , ToJSON a+     )+  => AlmostPrism (ExceptT SError) Data.ByteString.Lazy.ByteString a+jsonP = AlmostPrism+    ( ExceptT+      . Identity+      . Data.Bifunctor.first SError_JSONDecoding+      . Data.Aeson.eitherDecode+    )+    Data.Aeson.encode++-- * ProtoVersion++-- protoVersion_major & 0xFF00+-- protoVersion_minor & 0x00FF+-- Features are exchanged separately during handshake, not on wire here.+protoVersion :: NixSerializer 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+        , protoVersion_features = mempty+        }+  , putS = \p ->+      putS (int @Word32)+      $ ((Data.Bits.shiftL (fromIntegral $ protoVersion_major p :: Word32) 8)+          Data.Bits..|. fromIntegral (protoVersion_minor p))+  }++protoFeature :: NixSerializer SError ProtoFeature+protoFeature =+  mapPrismSerializer+    (AlmostPrism+      (\t ->+        maybe+          (throwError $ SError_UnknownProtoFeature t)+          pure+          (protoFeatureFromText t)+      )+      protoFeatureToText+    )+    text++-- | Features advertised by the other side during handshake.+--+-- Unknown features are dropped rather than rejected. The peer may+-- support features we do not know about, and negotiation intersects+-- with our own feature set anyway.+protoFeatures :: NixSerializer SError (Set ProtoFeature)+protoFeatures = Serializer+  { getS =+      Data.Set.fromList+      . Data.Maybe.mapMaybe protoFeatureFromText+      <$> getS (list text)+  , putS =+      putS (list text)+      . fmap protoFeatureToText+      . Data.Set.toList+  }++-- * StorePath++storePath :: StoreDir -> NixSerializer SError StorePath+storePath storeDir = mapPrismSerializer (storePathP storeDir) byteString++storePathP :: StoreDir -> AlmostPrism (ExceptT SError) ByteString StorePath+storePathP storeDir = AlmostPrism+  { _almostPrism_get =+      ExceptT+      . Identity+      . Data.Bifunctor.first SError_Path+      . System.Nix.StorePath.parsePath storeDir+  , _almostPrism_put = System.Nix.StorePath.storePathToRawFilePath storeDir+  }++maybePath+  :: StoreDir+  -> NixSerializer SError (Maybe StorePath)+maybePath storeDir = mapPrismSerializer (maybeAlmostPrism $ storePathP storeDir) maybeByteString++storePathHashPart :: NixSerializer SError StorePathHashPart+storePathHashPart =+  mapIsoSerializer+    System.Nix.StorePath.unsafeMakeStorePathHashPart+    System.Nix.StorePath.unStorePathHashPart+    $ mapPrismSerializer+        (AlmostPrism+          (ExceptT+           . Identity+           . Data.Bifunctor.first (pure SError_InvalidNixBase32)+           . System.Nix.Base.decodeWith NixBase32)+          (System.Nix.Base.encodeWith NixBase32)+        )+        text++storePathName :: NixSerializer SError StorePathName+storePathName =+  mapPrismSerializer+    (AlmostPrism+      (ExceptT+       . Identity+       . Data.Bifunctor.first SError_Name+       . System.Nix.StorePath.mkStorePathName)+      System.Nix.StorePath.unStorePathName+    )+    text++pathMetadata+  :: StoreDir+  -> NixSerializer SError (Metadata StorePath)+pathMetadata storeDir = Serializer+  { getS = do+      metadataDeriverPath <- getS $ maybePath storeDir++      digest' <- getS $ digest Base16+      let metadataNarHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest'++      metadataReferences <- getS $ hashSet $ storePath storeDir+      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 storeDir) metadataDeriverPath++      let putNarHash+            :: DSum HashAlgo Digest+            -> PutM ()+          putNarHash = \case+            System.Nix.Hash.HashAlgo_SHA256 :=> d+              -> putS (digest @SHA256 Base16) d+            _ -> error "nar hash must be SHA 256"+                 -- throwError SError_NarHashMustBeSHA256++      putNarHash metadataNarHash++      putS (hashSet $ storePath storeDir) metadataReferences+      putS time metadataRegistrationTime+      putS int $ Data.Maybe.fromMaybe 0 metadataNarBytes+      putS storePathTrust metadataTrust+      putS (set narSignature) metadataSigs+      putS maybeContentAddress metadataContentAddress+  }+  where+    maybeContentAddress+      :: NixSerializer SError (Maybe ContentAddress)+    maybeContentAddress =+      mapPrismSerializer+        (maybeAlmostPrism $ AlmostPrism+          (ExceptT+           . Identity+           . Data.Bifunctor.first SError_ContentAddress+           . System.Nix.ContentAddress.parseContentAddress+          )+          System.Nix.ContentAddress.buildContentAddress+        )+        maybeText++    storePathTrust+      :: NixSerializer SError StorePathTrust+    storePathTrust =+      mapIsoSerializer+        (\case False -> BuiltElsewhere; True -> BuiltLocally)+        (\case BuiltElsewhere -> False; BuiltLocally -> True)+        bool++-- | Read/write a full ValidPathInfo (StorePath + Metadata) as one unit.+validPathInfo+  :: StoreDir+  -> NixSerializer SError (StorePath, Metadata StorePath)+validPathInfo storeDir = Serializer+  { getS = do+      path <- getS (storePath storeDir)+      metadata <- getS (pathMetadata storeDir)+      pure (path, metadata)+  , putS = \(path, metadata) -> do+      putS (storePath storeDir) path+      putS (pathMetadata storeDir) metadata+  }++-- * OutputName++outputName :: NixSerializer SError OutputName+outputName =+  mapIsoSerializer+    System.Nix.OutputName.OutputName+     System.Nix.OutputName.unOutputName+    storePathName++-- * Signatures++signature+  :: NixSerializer SError Signature+signature =+  mapPrismSerializer+    (AlmostPrism+      (ExceptT+       . Identity+       . Data.Bifunctor.first SError_Signature+       . Data.Attoparsec.Text.parseOnly+           System.Nix.Signature.signatureParser)+      (System.Nix.Signature.signatureToText)+    )+    text++narSignature+  :: NixSerializer SError NamedSignature+narSignature =+  mapPrismSerializer+    (AlmostPrism+      (ExceptT+       . Identity+       . Data.Bifunctor.first SError_Signature+       . Data.Attoparsec.Text.parseOnly+           System.Nix.Signature.narSignatureParser)+      (System.Nix.Signature.narSignatureToText)+    )+    text++-- * Some HashAlgo++someHashAlgo :: NixSerializer SError (Some HashAlgo)+someHashAlgo =+  mapPrismSerializer+    (AlmostPrism+      (ExceptT+       . Identity+       . Data.Bifunctor.first SError_HashAlgo+       . System.Nix.Hash.textToAlgo)+      (Data.Some.foldSome System.Nix.Hash.algoToText)+    )+    text++-- * Digest++digest+  :: forall a+   . HashAlgorithm a+  => BaseEncoding+  -> NixSerializer SError (Digest a)+digest base = mapPrismSerializer (digestP base) $ text++digestP+  :: forall a+  . HashAlgorithm a+  => BaseEncoding+  -> AlmostPrism (ExceptT SError) Text (Digest a)+digestP base = AlmostPrism+  (ExceptT+   . Identity+   . Data.Bifunctor.first SError_Digest+   . System.Nix.Hash.decodeDigestWith @a base)+  (System.Nix.Hash.encodeDigestWith base)++-- * DSum HashAlgo Digest++namedDigest :: NixSerializer 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+  :: StoreDir+  -> NixSerializer SError FreeformDerivationOutput+derivationOutput storeDir = Serializer+  { getS = do+      rawPath <- getS text+      rawMethodHashAlgo <- getS text+      rawHash <- getS text+      parseRawDerivationOutput storeDir $ RawDerivationOutput {..}+  , putS = \output -> do+      let RawDerivationOutput {..} = renderRawDerivationOutput storeDir output+      putS text rawPath+      putS text rawMethodHashAlgo+      putS text rawHash+  }++-- * Derivation++basicDerivation+  :: StoreDir+  -> NixSerializer SError (TraditionalDerivation' (Set StorePath) FreeformDerivationOutputs)+basicDerivation storeDir = Serializer+  { getS = do+      anonOutputs <- getS $ mapS' $ tup outputName $ derivationOutput storeDir+      anonInputs <- getS $ set $ storePath storeDir+      anonPlatform <- getS text+      anonBuilder <- getS text+      anonArgs <- getS $ vector text+      anonEnv <- getS $ mapS text text+      pure $ TraditionalDerivation{..}+  , putS = \TraditionalDerivation{..} -> do+      putS (mapS' $ tup outputName $ derivationOutput storeDir) anonOutputs+      putS (set $ storePath storeDir) anonInputs+      putS text anonPlatform+      putS text anonBuilder+      putS (vector text) anonArgs+      putS (mapS text text) anonEnv+  }++-- * DerivedPath++derivedPathNew+  :: StoreDir+  -> NixSerializer SError DerivedPath+derivedPathNew storeDir = Serializer+  { getS = do+      p <- getS text+      case System.Nix.DerivedPath.parseDerivedPath storeDir p of+        Left err -> throwError $ SError_DerivedPath err+        Right x -> pure x+  , putS = \d -> do+      putS text (System.Nix.DerivedPath.derivedPathToText storeDir d)+  }++derivedPath+  :: StoreDir+  -> NixSerializer SError DerivedPath+derivedPath storeDir = Serializer+  { getS = getS $ derivedPathNew storeDir+  , putS = putS (derivedPathNew storeDir)+  }++-- | Tagged, recursive format used by the builder-rpc-v0 operations,+-- unlike 'derivedPath' which round-trips through the textual+-- rendering.+singleDerivedPath+  :: StoreDir+  -> NixSerializer SError SingleDerivedPath+singleDerivedPath storeDir = Serializer+  { getS = getS (int @Word64) >>= \case+      0 -> SingleDerivedPath_Opaque <$> getS (storePath storeDir)+      1 -> do+        drvPath <- getS (singleDerivedPath storeDir)+        output <- getS outputName+        pure $ SingleDerivedPath_Built drvPath output+      x -> throwError $ SError_SingleDerivedPathInvalidTag x+  , putS = \case+      SingleDerivedPath_Opaque p -> do+        putS (int @Word64) 0+        putS (storePath storeDir) p+      SingleDerivedPath_Built drvPath output -> do+        putS (int @Word64) 1+        putS (singleDerivedPath storeDir) drvPath+        putS outputName output+  }++-- * Build++buildMode :: NixSerializer SError BuildMode+buildMode = enum++-- * Logger++data LoggerSError+  = LoggerSError_Prim SError+  | LoggerSError_InvalidOpCode Word64+  | LoggerSError_UnknownLogFieldType Word8+  deriving (Eq, Generic, Show)++mapPrimE+  :: Functor m+  => ExceptT SError m a+  -> ExceptT LoggerSError m a+mapPrimE = withExceptT LoggerSError_Prim++maybeActivity :: NixSerializer 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 LoggerSError Activity+activity = Serializer+  { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100))+  , putS = putS int . (+100) . fromEnum+  }++activityID :: NixSerializer LoggerSError ActivityID+activityID = mapIsoSerializer ActivityID unActivityID int++activityResult :: NixSerializer LoggerSError ActivityResult+activityResult = Serializer+  { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100))+  , putS = putS int . (+100) . fromEnum+  }++field :: NixSerializer 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) >> putS text x+  }++trace :: NixSerializer 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+      putS text traceHint+  }++errorInfo :: NixSerializer 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+      do+        putS text $ Data.Text.pack "Error"+      putS verbosity errorInfoLevel+      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 LoggerSError LoggerOpCode+loggerOpCode = Serializer+  { getS = do+      c <- getS int+      either+        (pure $ throwError (LoggerSError_InvalidOpCode c))+        pure+        $ word64ToLoggerOpCode c+  , putS = putS int . loggerOpCodeToWord64+  }++logger+  :: ProtoVersion+  -> NixSerializer LoggerSError Logger+logger _pv = 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+        Logger_Error <$> getS errorInfo++      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+          putS text s++        Logger_Read i -> do+          putS loggerOpCode LoggerOpCode_Read+          putS int i++        Logger_Write s -> do+          putS loggerOpCode LoggerOpCode_Write+          putS byteString s++        Logger_Last ->+          putS loggerOpCode LoggerOpCode_Last++        Logger_Error e -> do+          putS loggerOpCode LoggerOpCode_Error+          putS errorInfo e++        Logger_StartActivity{..} -> do+          putS loggerOpCode LoggerOpCode_StartActivity+          putS activityID startActivityID+          putS verbosity startActivityVerbosity+          putS maybeActivity startActivityType+          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 LoggerSError Verbosity+verbosity = Serializer+  { getS = mapPrimE $ getS enum+  , putS = putS enum+  }++-- * Handshake++data HandshakeSError+  = HandshakeSError_InvalidWorkerMagic Word64+  | HandshakeSError_InvalidTrustedFlag Word8+  deriving (Eq, Ord, Generic, Show)++workerMagic :: NixSerializer HandshakeSError WorkerMagic+workerMagic = Serializer+  { getS = do+      c <- getS int+      either+        (pure $ throwError (HandshakeSError_InvalidWorkerMagic c))+        pure+        $ word64ToWorkerMagic c+  , putS = putS int . workerMagicToWord64+  }++trustedFlag :: NixSerializer 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 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 SError WorkerOp+workerOp = Serializer+  { getS = getS int >>=+      either+        (throwError . SError_InvalidWorkerOp)+        pure+      . word64ToWorkerOp+  , putS = putS int . workerOpToWord64+  }++-- * Request++data RequestSError+  = RequestSError_NotYetImplemented WorkerOp+  | RequestSError_ReservedOp WorkerOp+  | RequestSError_PrimGet SError+  | RequestSError_PrimWorkerOp SError+  deriving (Eq, Generic, Show)++storeRequest+  :: StoreDir+  -> ProtoVersion+  -> NixSerializer RequestSError (Some StoreRequest)+storeRequest storeDir _pv = Serializer+  { getS = withExceptT RequestSError_PrimWorkerOp (getS workerOp) >>= \case+      WorkerOp_AddToStore -> mapGetE $ do+        pathName <- getS storePathName+        camStr <- getS text+        (method, hashAlgo) <- case Data.Attoparsec.Text.parseOnly methodAlgoParser camStr of+          Left e -> fail e+          Right x -> pure x+        refs <- getS (set (storePath storeDir))+        repairBool <- getS bool+        let repair = if repairBool then RepairMode_DoRepair else RepairMode_DontRepair+        pure $ Some (AddToStore pathName method hashAlgo refs repair)++      WorkerOp_AddToStoreScanning -> mapGetE $ do+        pathName <- getS storePathName+        camStr <- getS text+        (method, hashAlgo) <- case Data.Attoparsec.Text.parseOnly methodAlgoParser camStr of+          Left e -> fail e+          Right x -> pure x+        pure $ Some (AddToStoreScanning pathName method hashAlgo)++      WorkerOp_AddToStoreNar -> mapGetE $ do+        storePath' <- getS $ storePath storeDir+        metadata <- getS $ pathMetadata storeDir+        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 storeDir+        let repair = RepairMode_DontRepair+        pure $ Some (AddTextToStore txt paths repair)++      WorkerOp_AddSignatures -> mapGetE $ do+        path <- getS $ storePath storeDir+        signatures <- getS (set signature)+        pure $ Some (AddSignatures path signatures)++      WorkerOp_AddIndirectRoot -> mapGetE $ do+        Some . AddIndirectRoot <$> getS (storePath storeDir)++      WorkerOp_AddTempRoot -> mapGetE $ do+        Some . AddTempRoot <$> getS (storePath storeDir)++      WorkerOp_BuildPaths -> mapGetE $ do+        derived <- getS (set $ derivedPath storeDir)+        buildMode' <- getS buildMode+        pure $ Some (BuildPaths derived buildMode')++      WorkerOp_BuildDerivation -> mapGetE $ do+        path <- getS $ storePath storeDir+        let name = System.Nix.StorePath.storePathName path+        drv0 <- getS $ basicDerivation storeDir+        let drv1 = withName name drv0+        outputs <- toSpecificOutputs storeDir name $ outputs drv1+        let drv2 = drv1 { outputs = outputs }+        buildMode' <- getS buildMode+        pure $ Some (BuildDerivation path drv2 buildMode')++      WorkerOp_CollectGarbage -> mapGetE $ do+        gcOptionsOperation <- getS enum+        gcOptionsPathsToDelete <- getS (hashSet $ storePath storeDir)+        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 storeDir)++      WorkerOp_FindRoots -> mapGetE $ do+        pure $ Some FindRoots++      WorkerOp_IsValidPath -> mapGetE $ do+        Some . IsValidPath <$> getS (storePath storeDir)++      WorkerOp_NarFromPath -> mapGetE $ do+        Some . NarFromPath <$> getS (storePath storeDir)++      WorkerOp_QueryValidPaths -> mapGetE $ do+        paths <- getS (hashSet $ storePath storeDir)+        substituteMode <- getS enum+        pure $ Some (QueryValidPaths paths substituteMode)++      WorkerOp_QueryAllValidPaths -> mapGetE $ do+        pure $ Some QueryAllValidPaths++      WorkerOp_QuerySubstitutablePaths -> mapGetE $ do+        Some . QuerySubstitutablePaths <$> getS (hashSet $ storePath storeDir)++      WorkerOp_QueryPathInfo -> mapGetE $ do+        Some . QueryPathInfo <$> getS (storePath storeDir)++      WorkerOp_QueryReferrers -> mapGetE $ do+        Some . QueryReferrers <$> getS (storePath storeDir)++      WorkerOp_QueryValidDerivers -> mapGetE $ do+        Some . QueryValidDerivers <$> getS (storePath storeDir)++      WorkerOp_QueryDerivationOutputs -> mapGetE $ do+        Some . QueryDerivationOutputs <$> getS (storePath storeDir)++      WorkerOp_QueryDerivationOutputNames -> mapGetE $ do+        Some . QueryDerivationOutputNames <$> getS (storePath storeDir)++      WorkerOp_QueryPathFromHashPart -> mapGetE $ do+        Some . QueryPathFromHashPart <$> getS storePathHashPart++      WorkerOp_QueryMissing -> mapGetE $ do+        Some . QueryMissing <$> getS (set $ derivedPath storeDir)++      WorkerOp_OptimiseStore -> mapGetE $ do+        pure $ Some OptimiseStore++      WorkerOp_SubmitOutput -> mapGetE $ do+        path <- getS $ singleDerivedPath storeDir+        output <- getS outputName+        pure $ Some (SubmitOutput path output)++      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 method hashAlgo refs repair) -> do+        putS workerOp WorkerOp_AddToStore++        putS storePathName pathName+        putS text+          $ Data.Text.Lazy.toStrict+          $ Data.Text.Lazy.Builder.toLazyText+          $ methodAlgoBuilder method hashAlgo+        putS (set (storePath storeDir)) refs+        putS bool (repair == RepairMode_DoRepair)++      Some (AddToStoreScanning pathName method hashAlgo) -> do+        putS workerOp WorkerOp_AddToStoreScanning++        putS storePathName pathName+        putS text+          $ Data.Text.Lazy.toStrict+          $ Data.Text.Lazy.Builder.toLazyText+          $ methodAlgoBuilder method hashAlgo++      Some (AddToStoreNar storePath' metadata repair checkSigs) -> do+        putS workerOp WorkerOp_AddToStoreNar++        putS (storePath storeDir) storePath'+        putS (pathMetadata storeDir) metadata+        putS bool $ repair == RepairMode_DoRepair+        putS bool $ checkSigs == CheckMode_DontCheck++      Some (AddTextToStore txt paths _repair) -> do+        putS workerOp WorkerOp_AddTextToStore++        putS storeText txt+        putS (hashSet $ storePath storeDir) paths++      Some (AddSignatures path signatures) -> do+        putS workerOp WorkerOp_AddSignatures++        putS (storePath storeDir) path+        putS (set signature) signatures++      Some (AddIndirectRoot path) -> do+        putS workerOp WorkerOp_AddIndirectRoot+        putS (storePath storeDir) path++      Some (AddTempRoot path) -> do+        putS workerOp WorkerOp_AddTempRoot+        putS (storePath storeDir) path++      Some (BuildPaths derived buildMode') -> do+        putS workerOp WorkerOp_BuildPaths++        putS (set $ derivedPath storeDir) derived+        putS buildMode buildMode'++      Some (BuildDerivation path drv0 buildMode') -> do+        putS workerOp WorkerOp_BuildDerivation++        putS (storePath storeDir) path+        let drv1 = drv0 { outputs = fromSpecificOutputs storeDir (name drv0) $ outputs drv0 }+        let drv2 = withoutName drv1+        putS (basicDerivation storeDir) drv2+        putS buildMode buildMode'++      Some (CollectGarbage GCOptions{..}) -> do+        putS workerOp WorkerOp_CollectGarbage++        putS enum gcOptionsOperation+        putS (hashSet $ storePath storeDir) gcOptionsPathsToDelete+        putS bool gcOptionsIgnoreLiveness+        putS int gcOptionsMaxFreed+        -- obsolete fields+        Control.Monad.forM_ [0..(2 :: Word8)]+          $ pure $ putS int (0 :: Word8)++      Some (EnsurePath path) -> do+        putS workerOp WorkerOp_EnsurePath+        putS (storePath storeDir) path++      Some FindRoots -> do+        putS workerOp WorkerOp_FindRoots++      Some (IsValidPath path) -> do+        putS workerOp WorkerOp_IsValidPath+        putS (storePath storeDir) path++      Some (NarFromPath path) -> do+        putS workerOp WorkerOp_NarFromPath+        putS (storePath storeDir) path++      Some (QueryValidPaths paths substituteMode) -> do+        putS workerOp WorkerOp_QueryValidPaths++        putS (hashSet $ storePath storeDir) paths+        putS enum substituteMode++      Some QueryAllValidPaths -> do+        putS workerOp WorkerOp_QueryAllValidPaths++      Some (QuerySubstitutablePaths paths) -> do+        putS workerOp WorkerOp_QuerySubstitutablePaths+        putS (hashSet $ storePath storeDir) paths++      Some (QueryPathInfo path) -> do+        putS workerOp WorkerOp_QueryPathInfo+        putS (storePath storeDir) path++      Some (QueryReferrers path) -> do+        putS workerOp WorkerOp_QueryReferrers+        putS (storePath storeDir) path++      Some (QueryValidDerivers path) -> do+        putS workerOp WorkerOp_QueryValidDerivers+        putS (storePath storeDir) path++      Some (QueryDerivationOutputs path) -> do+        putS workerOp WorkerOp_QueryDerivationOutputs+        putS (storePath storeDir) path++      Some (QueryDerivationOutputNames path) -> do+        putS workerOp WorkerOp_QueryDerivationOutputNames+        putS (storePath storeDir) path++      Some (QueryPathFromHashPart pathHashPart) -> do+        putS workerOp WorkerOp_QueryPathFromHashPart+        putS storePathHashPart pathHashPart++      Some (QueryMissing derived) -> do+        putS workerOp WorkerOp_QueryMissing+        putS (set $ derivedPath storeDir) derived++      Some OptimiseStore -> do+        putS workerOp WorkerOp_OptimiseStore++      Some (SubmitOutput path output) -> do+        putS workerOp WorkerOp_SubmitOutput++        putS (singleDerivedPath storeDir) path+        putS outputName output++      Some SyncWithGC -> do+        putS workerOp WorkerOp_SyncWithGC++      Some (VerifyStore checkMode repairMode) -> do+        putS workerOp WorkerOp_VerifyStore+        putS enum checkMode+        putS enum repairMode+  }+  where+    mapGetE+      :: Functor m+      => ExceptT SError m a+      -> ExceptT RequestSError m a+    mapGetE = withExceptT RequestSError_PrimGet++    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_GCResult SError+  | ReplySError_Metadata SError+  | ReplySError_Missing SError+  | ReplySError_Realisation SError+  | ReplySError_RealisationWithId SError+  | ReplySError_UnexpectedFalseOpSuccess+  deriving (Eq, Generic, Show)++mapGetER+  :: Functor m+  => ExceptT SError m a+  -> ExceptT ReplySError m a+mapGetER = withExceptT ReplySError_PrimGet++-- | Parse a bool returned at the end of simple operations.+-- This is always 1 (@True@) so we assert that it really is so.+-- Errors for these operations are indicated via @Logger_Error@.+opSuccess :: NixSerializer ReplySError SuccessCodeReply+opSuccess = Serializer+  { getS = do+      retCode <- mapGetER $ getS bool+      Control.Monad.unless+        (retCode == True)+        $ throwError ReplySError_UnexpectedFalseOpSuccess+      pure SuccessCodeReply+  , putS = \_ -> putS bool True+  }++noop :: a -> NixSerializer ReplySError a+noop ret = Serializer+  { getS = pure ret+  , putS = \_ -> pure ()+  }++-- *** Realisation++realisation :: NixSerializer ReplySError Realisation+realisation = mapErrorS ReplySError_Realisation json++-- *** BuildResult++buildResult+  :: StoreDir+  -> ProtoVersion+  -> NixSerializer ReplySError BuildResult+buildResult _storeDir pv = Serializer+  { getS = do+      statusWord <- mapGetER $ getS enum+      errorMessage <- mapGetER $ getS maybeText++      ( buildResultTimesBuilt+        , isNonDeterministic+        , buildResultStartTime+        , buildResultStopTime+        ) <-+        mapGetER $ do+          tb <- 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, nondet, start, end)++      Control.Monad.unless (hasFeature ProtoFeature_RealisationWithPathNotHash pv)+        $ fail "missing required feature: realisation-with-path-not-hash"+      parsedBuiltOutputs <-+        getS (mapS (mapErrorS ReplySError_PrimGet outputName) realisation)++      let buildResultStatus = case (wireToStatus statusWord, errorMessage) of+            (Right successStatus, _) -> Right $ BuildSuccess successStatus parsedBuiltOutputs+            (Left failureStatus, Just errorMsg) -> Left $ BuildFailure failureStatus errorMsg isNonDeterministic+            (Left failureStatus, Nothing) -> Left $ BuildFailure failureStatus Data.Text.empty isNonDeterministic++      let buildResultStartTime' = Data.Maybe.fromMaybe t0 buildResultStartTime+          buildResultStopTime' = Data.Maybe.fromMaybe t0 buildResultStopTime+          buildResultCpuUser = Nothing+          buildResultCpuSystem = Nothing++      pure BuildResult+        { buildResultStatus = buildResultStatus+        , buildResultTimesBuilt = buildResultTimesBuilt+        , buildResultStartTime = buildResultStartTime'+        , buildResultStopTime = buildResultStopTime'+        , buildResultCpuUser = buildResultCpuUser+        , buildResultCpuSystem = buildResultCpuSystem+        }++  , putS = \BuildResult{..} -> do+      let (statusWord, errorMessage, isNonDeterministic) = case buildResultStatus of+            Right (BuildSuccess st _bo) -> (successStatusToWire st, Nothing, False)+            Left (BuildFailure st em nd) -> (failureStatusToWire st, Just em, nd)++      putS enum statusWord+      putS maybeText errorMessage+      putS int buildResultTimesBuilt+      putS bool isNonDeterministic+      putS time buildResultStartTime+      putS time buildResultStopTime+      let builtOutputs = case buildResultStatus of+            Right (BuildSuccess _ bo) -> bo+            Left _ -> mempty+      putS (mapS (mapErrorS ReplySError_PrimGet outputName) realisation) builtOutputs+  }+  where+    t0 :: UTCTime+    t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0++    -- Convert wire format status code to either success or failure status+    wireToStatus :: Word8 -> Either BuildFailureStatus BuildSuccessStatus+    wireToStatus 0 = Right BuildSuccessStatus_Built+    wireToStatus 1 = Right BuildSuccessStatus_Substituted+    wireToStatus 2 = Right BuildSuccessStatus_AlreadyValid+    wireToStatus 3 = Left BuildFailureStatus_PermanentFailure+    wireToStatus 4 = Left BuildFailureStatus_InputRejected+    wireToStatus 5 = Left BuildFailureStatus_OutputRejected+    wireToStatus 6 = Left BuildFailureStatus_TransientFailure+    wireToStatus 7 = Left BuildFailureStatus_CachedFailure+    wireToStatus 8 = Left BuildFailureStatus_TimedOut+    wireToStatus 9 = Left BuildFailureStatus_MiscFailure+    wireToStatus 10 = Left BuildFailureStatus_DependencyFailed+    wireToStatus 11 = Left BuildFailureStatus_LogLimitExceeded+    wireToStatus 12 = Left BuildFailureStatus_NotDeterministic+    wireToStatus 13 = Right BuildSuccessStatus_ResolvesToAlreadyValid+    wireToStatus 14 = Left BuildFailureStatus_NoSubstituters+    wireToStatus 15 = Left BuildFailureStatus_HashMismatch+    wireToStatus _ = Left BuildFailureStatus_MiscFailure++    -- Convert success status to wire format+    successStatusToWire :: BuildSuccessStatus -> Word8+    successStatusToWire BuildSuccessStatus_Built = 0+    successStatusToWire BuildSuccessStatus_Substituted = 1+    successStatusToWire BuildSuccessStatus_AlreadyValid = 2+    successStatusToWire BuildSuccessStatus_ResolvesToAlreadyValid = 13++    -- Convert failure status to wire format+    failureStatusToWire :: BuildFailureStatus -> Word8+    failureStatusToWire BuildFailureStatus_PermanentFailure = 3+    failureStatusToWire BuildFailureStatus_InputRejected = 4+    failureStatusToWire BuildFailureStatus_OutputRejected = 5+    failureStatusToWire BuildFailureStatus_TransientFailure = 6+    failureStatusToWire BuildFailureStatus_CachedFailure = 7+    failureStatusToWire BuildFailureStatus_TimedOut = 8+    failureStatusToWire BuildFailureStatus_MiscFailure = 9+    failureStatusToWire BuildFailureStatus_DependencyFailed = 10+    failureStatusToWire BuildFailureStatus_LogLimitExceeded = 11+    failureStatusToWire BuildFailureStatus_NotDeterministic = 12+    failureStatusToWire BuildFailureStatus_NoSubstituters = 14+    failureStatusToWire BuildFailureStatus_HashMismatch = 15++-- *** GCResult++gcResult+  :: StoreDir+  -> NixSerializer ReplySError GCResult+gcResult storeDir = mapErrorS ReplySError_GCResult $ Serializer+  { getS = do+      gcResultDeletedPaths <- getS (hashSet $ storePath storeDir)+      gcResultBytesFreed <- getS int+      Control.Monad.void $ getS (int @Word64) -- obsolete+      pure GCResult{..}+  , putS = \GCResult{..} -> do+      putS (hashSet $ storePath storeDir) gcResultDeletedPaths+      putS int gcResultBytesFreed+      putS (int @Word64) 0 -- obsolete+  }++-- *** GCRoot++gcRoot :: NixSerializer ReplySError GCRoot+gcRoot = Serializer+  { getS = mapGetER $ do+      getS byteString >>= \case+        p | p == censored -> pure GCRoot_Censored+        p -> pure (GCRoot_Path p)+  , putS = putS byteString . \case+      GCRoot_Censored -> censored+      GCRoot_Path p -> p+  }+  where censored = Data.ByteString.Char8.pack "{censored}"++-- *** Missing++missing+  :: StoreDir+  -> NixSerializer ReplySError Missing+missing storeDir = mapErrorS ReplySError_Missing $ Serializer+  { getS = do+      missingWillBuild <- getS (hashSet $ storePath storeDir)+      missingWillSubstitute <- getS (hashSet $ storePath storeDir)+      missingUnknownPaths <- getS (hashSet $ storePath storeDir)+      missingDownloadSize <- getS int+      missingNarSize <- getS int++      pure Missing{..}+  , putS = \Missing{..} -> do+      putS (hashSet $ storePath storeDir) missingWillBuild+      putS (hashSet $ storePath storeDir) missingWillSubstitute+      putS (hashSet $ storePath storeDir) missingUnknownPaths+      putS int missingDownloadSize+      putS int missingNarSize+  }++-- *** Maybe (Metadata StorePath)++maybePathMetadata+  :: StoreDir+  -> NixSerializer ReplySError (Maybe (Metadata StorePath))+maybePathMetadata storeDir = mapErrorS ReplySError_Metadata $ Serializer+  { getS = do+      valid <- getS bool+      if valid+      then pure <$> getS (pathMetadata storeDir)+      else pure Nothing+  , putS = \case+      Nothing -> putS bool False+      Just pm -> putS bool True >> putS (pathMetadata storeDir) pm+  }
+ src/System/Nix/Store/Remote/Server.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+module System.Nix.Store.Remote.Server+  ( runProxyDaemon+  , WorkerHelper+  )+  where++import Algebra.PartialOrd (leq)+import Control.Concurrent.Classy.Async+import Control.Monad (join, unless, 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.Set qualified+import Data.Text (Text)+import Data.Void (Void, absurd)+import Data.ByteString (ByteString)+import Data.Word (Word32, Word64)+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, validPathInfo, workerMagic, protoFeatures, 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(..), minVersionNumber)+import System.Nix.Store.Remote.Types.Logger (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 Data.Some qualified+import Data.Text.IO qualified+import Data.Bits (shiftL)+import Data.ByteString qualified+import Network.Socket.ByteString qualified++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+              let proxyNarSource :: NarSource IO+                  proxyNarSource sink = readFramedSource sock sink+              pure $ setNarSource proxyNarSource+            AddToStoreScanning {} -> do+              let proxyNarSource :: NarSource IO+                  proxyNarSource sink = readFramedSource sock sink+              pure $ setNarSource proxyNarSource+            _ -> pure $ pure ()++          res <-+            bracketLogger+              tunnelLogger+              $ lift+              $ workerHelper+              $ special >> doReq req++          case fst res of+            Left e -> throwError e+            Right reply -> do+              storeDir <- getStoreDir+              pv <- getProtoVersion+              case req of+                -- AddToStore returns ValidPathInfo on the wire,+                -- not just StorePath+                AddToStore {} -> do+                  -- Query the metadata so we can send full ValidPathInfo+                  metadata <- lift $ workerHelper $ doReq (QueryPathInfo reply)+                  case fst metadata of+                    Left e -> throwError e+                    Right (Just meta) ->+                      sockPutS+                        (mapErrorS RemoteStoreError_SerializerPut+                          $ validPathInfo storeDir)+                        (reply, meta)+                    Right Nothing ->+                      throwError $ RemoteStoreError_Fixme "AddToStore: path not found after adding"+                AddToStoreScanning {} -> do+                  metadata <- lift $ workerHelper $ doReq (QueryPathInfo reply)+                  case fst metadata of+                    Left e -> throwError e+                    Right (Just meta) ->+                      sockPutS+                        (mapErrorS RemoteStoreError_SerializerPut+                          $ validPathInfo storeDir)+                        (reply, meta)+                    Right Nothing ->+                      throwError $ RemoteStoreError_Fixme "AddToStoreScanning: path not found after adding"+                _ ->+                  sockPutS+                    (mapErrorS+                       RemoteStoreError_SerializerReply+                       $ getReplyS storeDir pv+                    )+                    reply++    -- Process client requests.+    let loop = do+          storeDir <- getStoreDir+          pv <- getProtoVersion+          someReq <-+            sockGetS+              $ mapErrorS+                  RemoteStoreError_SerializerRequest+                  (storeRequest storeDir pv)++          -- 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@AddToStoreScanning {} -> 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@SubmitOutput {} -> 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 = minVersionNumber clientVersion serverHandshakeInputOurVersion++      when (not (ProtoVersion 1 37 mempty `leq` clientVersion))+        $ throwError+        $ RemoteStoreError_WorkerException+            WorkerException_ClientVersionTooOld++      -- Feature exchange (>= 1.38)+      negotiatedFeatures <- if ProtoVersion 1 38 mempty `leq` leastCommonVersion+        then do+          clientFeatures <- sockGetS+            $ mapErrorS RemoteStoreError_SerializerGet protoFeatures+          sockPutS+            (mapErrorS RemoteStoreError_SerializerPut protoFeatures)+            (protoVersion_features serverHandshakeInputOurVersion)+          pure $ Data.Set.intersection clientFeatures (protoVersion_features serverHandshakeInputOurVersion)+        else pure mempty++      let leastCommonVersionWithFeatures = leastCommonVersion { protoVersion_features = negotiatedFeatures }++      -- postHandshake: read affinity (obsolete), reserveSpace (obsolete)+      x :: Word32 <- sockGetS int+      when (x /= 0) $ do+        -- Obsolete CPU affinity.+        _ :: Word32 <- sockGetS int+        pure ()++      _ :: Word32 <- sockGetS int -- obsolete reserveSpace++      sockPutS+        (mapErrorS RemoteStoreError_SerializerPut text)+        serverHandshakeInputNixVersion++      sockPutS+        (mapErrorS RemoteStoreError_SerializerHandshake trustedFlag)+        serverHandshakeInputTrust++      pure ServerHandshakeOutput+        { serverHandshakeOutputLeastCommonVersion = leastCommonVersionWithFeatures+        , 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, do pv <- getProtoVersion; sockPutS (logger pv) 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 []) $ do+  pv <- getProtoVersion+  let logger' = mapErrorS RemoteStoreError_SerializerLogger (logger pv)+  traverse_ (sockPutS logger') $ reverse p++stopWork+  :: MonadRemoteStore m+  => TunnelLogger+  -> m ()+stopWork x = updateLogger x $ \_ -> (,)+  (TunnelLoggerState False []) $ do+  pv <- getProtoVersion+  sockPutS (mapErrorS RemoteStoreError_SerializerLogger (logger pv)) 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+      pv <- getProtoVersion+      let logger' = mapErrorS RemoteStoreError_SerializerLogger (logger pv)+      sockPutS logger' (Logger_Error ex)+      pure True++updateLogger+  :: MonadRemoteStore m+  => TunnelLogger+  -> (TunnelLoggerState -> (TunnelLoggerState, m a))+  -> m a+updateLogger x = join . liftIO . atomicModifyIORef (_tunnelLogger_state x)++-- | Read framed source data from a socket.+--+-- The framed protocol sends chunks as: little-endian u64 length+-- followed by that many raw bytes, terminated by a zero-length frame.+readFramedSource+  :: Socket+  -> (ByteString -> IO ())+  -> IO ()+readFramedSource sock sink = go+  where+    go = do+      chunkLen <- recvWord64le sock+      unless (chunkLen == 0) $ do+        recvExact sock (fromIntegral chunkLen) sink+        go++    recvWord64le :: Socket -> IO Word64+    recvWord64le s = do+      bs <- recvExactBS s 8+      pure $ sum+        [ fromIntegral (Data.ByteString.index bs i) `shiftL` (i * 8)+        | i <- [0..7]+        ]++    recvExactBS :: Socket -> Int -> IO ByteString+    recvExactBS s n = do+      bs <- Network.Socket.ByteString.recv s n+      let got = Data.ByteString.length bs+      if got == 0 then fail "readFramedSource: unexpected EOF"+      else if got == n then pure bs+      else do+        rest <- recvExactBS s (n - got)+        pure $ bs <> rest++    recvExact :: Socket -> Int -> (ByteString -> IO ()) -> IO ()+    recvExact s remaining f = when (remaining > 0) $ do+      let toRead = min 16384 remaining+      bs <- Network.Socket.ByteString.recv s toRead+      let got = Data.ByteString.length bs+      when (got == 0) $ fail "readFramedSource: unexpected EOF"+      f bs+      recvExact s (remaining - got) f
+ src/System/Nix/Store/Remote/Socket.hs view
@@ -0,0 +1,94 @@+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, runExceptT, runP)++import Control.Exception qualified+import Data.ByteString qualified+import Data.Serializer qualified+import Data.Serialize.Get qualified++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+  => NixSerializer e a+  -> a+  -> m ()+sockPutS s a = do+  sock <- getStoreSocket+  liftIO $ sendAll sock $ runP s a++sockGetS+  :: ( MonadRemoteStore m+     , MonadError e m+     , Show a+     , Show e+     )+  => NixSerializer e a+  -> m a+sockGetS s = do+  res <- genericIncremental sockGet8+    $ runExceptT $ Data.Serializer.getS s++  case res of+    Right x -> pure x+    Left e -> throwError e
src/System/Nix/Store/Remote/Types.hs view
@@ -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
+ src/System/Nix/Store/Remote/Types/Activity.hs view
@@ -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)
+ src/System/Nix/Store/Remote/Types/CheckMode.hs view
@@ -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)
+ src/System/Nix/Store/Remote/Types/GC.hs view
@@ -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)
+ src/System/Nix/Store/Remote/Types/Handshake.hs view
@@ -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, 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, 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, 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, Show)
+ src/System/Nix/Store/Remote/Types/Logger.hs view
@@ -0,0 +1,100 @@+module System.Nix.Store.Remote.Types.Logger+  ( Field(..)+  , Trace(..)+  , 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)++-- | Extended error info+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 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
+ src/System/Nix/Store/Remote/Types/NoReply.hs view
@@ -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)+
+ src/System/Nix/Store/Remote/Types/ProtoVersion.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+module System.Nix.Store.Remote.Types.ProtoVersion+  ( ProtoVersion(..)+  , ProtoFeature(..)+  , protoFeatureToText+  , protoFeatureFromText+  , HasProtoVersion(..)+  , hasFeature+  , minVersionNumber+  , builderRpcV0+  ) where++import Algebra.PartialOrd (PartialOrd(..))+import Data.Default.Class (Default(def))+import Data.Set (Set)+import Data.Set qualified+import Data.Text (Text)+import Data.Word (Word8, Word16)+import GHC.Generics (Generic)++-- | An optional protocol capability, negotiated during handshake.+data ProtoFeature+  = ProtoFeature_AddToStoreScanning+  -- ^ The AddToStoreScanning operation, only offered by the daemon+  -- inside derivation builds with the @recursive-nix@ or+  -- @builder-rpc-v0@ system feature.+  | ProtoFeature_DisableSetOptions+  -- ^ The client promises not to send SetOptions after handshake.+  | ProtoFeature_RealisationWithPathNotHash+  -- ^ Use StorePath-based realisations instead of hash-based ones.+  | ProtoFeature_SubmitOutput+  -- ^ The SubmitOutput operation, only offered by the daemon inside+  -- derivation builds with the @builder-rpc-v0@ system feature.+  deriving (Bounded, Enum, Eq, Generic, Ord, Show)++-- | The name of a feature as exchanged on the wire.+protoFeatureToText :: ProtoFeature -> Text+protoFeatureToText = \case+  ProtoFeature_AddToStoreScanning -> "add-to-store-scanning"+  ProtoFeature_DisableSetOptions -> "disable-set-options"+  ProtoFeature_RealisationWithPathNotHash -> "realisation-with-path-not-hash"+  ProtoFeature_SubmitOutput -> "submit-output"++protoFeatureFromText :: Text -> Maybe ProtoFeature+protoFeatureFromText t =+  lookup t [ (protoFeatureToText f, f) | f <- [minBound .. maxBound] ]++data ProtoVersion = ProtoVersion+  { protoVersion_major :: Word16+  , protoVersion_minor :: Word8+  , protoVersion_features :: Set ProtoFeature+  }+  deriving (Eq, Generic, Show)++instance PartialOrd ProtoVersion where+  leq a b =+    (protoVersion_major a, protoVersion_minor a)+      <= (protoVersion_major b, protoVersion_minor b)+    && protoVersion_features a `Data.Set.isSubsetOf` protoVersion_features b++-- | Check whether a protocol version includes a given feature.+hasFeature :: ProtoFeature -> ProtoVersion -> Bool+hasFeature f = Data.Set.member f . protoVersion_features++-- | Take the minimum by version number, with empty features.+-- Used in handshake before feature negotiation.+minVersionNumber :: ProtoVersion -> ProtoVersion -> ProtoVersion+minVersionNumber a b =+  let (major', minor') = min+        (protoVersion_major a, protoVersion_minor a)+        (protoVersion_major b, protoVersion_minor b)+  in ProtoVersion major' minor' mempty++-- | The protocol version we support+instance Default ProtoVersion where+  def = ProtoVersion+    { protoVersion_major = 1+    , protoVersion_minor = 38+    , protoVersion_features = Data.Set.singleton ProtoFeature_RealisationWithPathNotHash+    }++-- | The protocol profile spoken on the daemon socket exposed to+-- builders of derivations with the @builder-rpc-v0@ system feature.+--+-- Frozen upstream, since any change would be derivation-visible.+builderRpcV0 :: ProtoVersion+builderRpcV0 = ProtoVersion+  { protoVersion_major = 1+  , protoVersion_minor = 38+  , protoVersion_features = Data.Set.fromList+      [ ProtoFeature_RealisationWithPathNotHash+      , ProtoFeature_DisableSetOptions+      , ProtoFeature_AddToStoreScanning+      , ProtoFeature_SubmitOutput+      ]+  }++class HasProtoVersion r where+  hasProtoVersion :: r -> ProtoVersion++instance HasProtoVersion ProtoVersion where+  hasProtoVersion = id
+ src/System/Nix/Store/Remote/Types/Query.hs view
@@ -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
+ src/System/Nix/Store/Remote/Types/Query/Missing.hs view
@@ -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)
+ src/System/Nix/Store/Remote/Types/StoreConfig.hs view
@@ -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, 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
+ src/System/Nix/Store/Remote/Types/StoreReply.hs view
@@ -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 (StoreDir, 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.ProtoVersion (ProtoVersion)+import System.Nix.Store.Remote.Types.Query.Missing (Missing)++-- | 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 :: StoreDir -> ProtoVersion -> NixSerializer 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 sd pv = buildResult sd pv++instance StoreReply GCResult where+  getReplyS sd _ = gcResult sd++instance StoreReply (Map GCRoot StorePath) where+  getReplyS sd _ = mapS gcRoot (mapPrimE (storePath sd))++instance StoreReply Missing where+  getReplyS sd _ = missing sd++instance StoreReply (Maybe (Metadata StorePath)) where+  getReplyS sd _ = maybePathMetadata sd++instance StoreReply StorePath where+  getReplyS sd _ = mapPrimE (storePath sd)++instance StoreReply (HashSet StorePath) where+  getReplyS sd _ = mapPrimE (hashSet (storePath sd))++instance StoreReply (HashSet StorePathName) where+  getReplyS _ _ = mapPrimE (hashSet storePathName)++mapPrimE+  :: NixSerializer SError a+  -> NixSerializer ReplySError a+mapPrimE = mapErrorS ReplySError_PrimGet
+ src/System/Nix/Store/Remote/Types/StoreRequest.hs view
@@ -0,0 +1,229 @@+{-# 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.Some (Some(Some))++import System.Nix.Build (BuildMode, BuildResult)+import System.Nix.Derivation (BasicDerivation)+import System.Nix.DerivedPath (DerivedPath, SingleDerivedPath)+import System.Nix.ContentAddress (ContentAddressMethod)+import System.Nix.Hash (HashAlgo)+import System.Nix.OutputName (OutputName)+import System.Nix.Signature (Signature)+import System.Nix.Store.Types (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@+    -> ContentAddressMethod -- ^ Content addressing method+    -> Some HashAlgo -- ^ Hashing algorithm+    -> Set StorePath -- ^ References+    -> RepairMode+    -> StoreRequest StorePath++  -- | Add a NAR with Metadata to the store.+  AddToStoreNar+    :: StorePath+    -> Metadata StorePath+    -> RepairMode+    -> CheckMode -- ^ Whether to check signatures+    -> StoreRequest NoReply++  -- | Add @NarSource@ to the store, letting the daemon scan the+  -- contents for references instead of declaring them.+  --+  -- Only available inside a derivation build with the+  -- @recursive-nix@ or @builder-rpc-v0@ system feature, when the+  -- @add-to-store-scanning@ protocol feature was negotiated.+  AddToStoreScanning+    :: StorePathName -- ^ Name part of the newly created @StorePath@+    -> ContentAddressMethod -- ^ Content addressing method+    -> Some HashAlgo -- ^ Hashing algorithm+    -> StoreRequest StorePath++  -- | 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+    -> BasicDerivation+    -> 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++  -- | Register a store object as an output of the currently running+  -- derivation.+  --+  -- Only available inside a derivation build with the+  -- @builder-rpc-v0@ system feature, when the @submit-output@+  -- protocol feature was negotiated.+  SubmitOutput+    :: SingleDerivedPath+    -> OutputName+    -> 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 e) == Some (AddToStore a' b' c' d' e') = (a, b, c, d, e) == (a', b', c', d', e')+  Some (AddToStoreNar a b c d) == Some (AddToStoreNar a' b' c' d') = (a, b, c, d) == (a', b', c', d')+  Some (AddToStoreScanning a b c) == Some (AddToStoreScanning a' b' c') = (a, b, c) == (a', b', c')+  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 (SubmitOutput a b) == Some (SubmitOutput a' b') = (a, b) == (a', b')+  Some SyncWithGC == Some SyncWithGC = True+  Some (VerifyStore a b) == Some (VerifyStore a' b') = (a, b) == (a', b')++  _ == _ = False
+ src/System/Nix/Store/Remote/Types/StoreText.hs view
@@ -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)
+ src/System/Nix/Store/Remote/Types/SubstituteMode.hs view
@@ -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)
+ src/System/Nix/Store/Remote/Types/SuccessCodeReply.hs view
@@ -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)+
+ src/System/Nix/Store/Remote/Types/TrustedFlag.hs view
@@ -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)
+ src/System/Nix/Store/Remote/Types/Verbosity.hs view
@@ -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)
+ src/System/Nix/Store/Remote/Types/WorkerMagic.hs view
@@ -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
+ src/System/Nix/Store/Remote/Types/WorkerOp.hs view
@@ -0,0 +1,81 @@+module System.Nix.Store.Remote.Types.WorkerOp+  ( WorkerOp(..)+  , workerOpToWord64+  , word64ToWorkerOp+  ) where++import Data.Word (Word64)+import GHC.Generics (Generic)++-- | Worker opcode+--+-- This type has gaps filled in so that the GHC builtin+-- Enum instance lands on the right values for the contiguous+-- 0-46 range. The builder-rpc-v0 opcodes at 1000+ don't follow+-- the Enum values, so the wire mapping goes through+-- 'workerOpToWord64' and 'word64ToWorkerOp'.+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+  | WorkerOp_SubmitOutput -- 1000, builder-rpc-v0 only+  | WorkerOp_AddToStoreScanning -- 1001, recursive-nix or builder-rpc-v0 only+  deriving (Bounded, Eq, Enum, Generic, Ord, Show, Read)++workerOpToWord64 :: WorkerOp -> Word64+workerOpToWord64 = \case+  WorkerOp_SubmitOutput -> 1000+  WorkerOp_AddToStoreScanning -> 1001+  op -> fromIntegral (fromEnum op)++word64ToWorkerOp :: Word64 -> Either Word64 WorkerOp+word64ToWorkerOp = \case+  1000 -> Right WorkerOp_SubmitOutput+  1001 -> Right WorkerOp_AddToStoreScanning+  x | x <= fromIntegral (fromEnum WorkerOp_BuildPathsWithResults) ->+        Right $ toEnum $ fromIntegral x+    | otherwise -> Left x
− src/System/Nix/Store/Remote/Util.hs 
@@ -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
+ tests-io/DataSink.hs view
@@ -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
+ tests-io/Main.hs view
@@ -0,0 +1,12 @@+module Main where++import Test.Hspec qualified+import NixDaemonSpec qualified++-- we run remote tests in+-- Linux namespaces to avoid interacting with systems store+main :: IO ()+main = do+  NixDaemonSpec.enterNamespaces+  Test.Hspec.hspec+    NixDaemonSpec.spec
+ tests-io/NixDaemonSpec.hs view
@@ -0,0 +1,524 @@+{-# 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.ContentAddress (ContentAddressMethod(..))+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 Control.Concurrent qualified+import Control.Exception qualified+import Data.ByteString.Char8 qualified+import Data.Either qualified+import Data.HashSet qualified+import Data.Map qualified+import Data.Set qualified+import Data.Text qualified+import Data.Text.Encoding qualified+import DataSink qualified+import SampleNar qualified+import System.Directory qualified+import System.Environment qualified+import System.IO.Temp qualified+import System.Linux.Namespaces qualified+import System.Nix.StorePath qualified+import System.Nix.Nar qualified+import System.Posix.User qualified+import System.Process qualified+import Test.Hspec qualified++createProcessEnv+  :: FilePath+  -> 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")+    ContentAddressMethod_NixArchive+    (Some HashAlgo_SHA256)+    mempty+    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)+        ContentAddressMethod_NixArchive+        (Some HashAlgo_SHA256)+        mempty+        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"
+ tests-io/SampleNar.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns #-}++module SampleNar++( SampleNar(..)+, buildDataSource+, sampleNar0+, encodeNar+)++where++import Crypto.Hash ( Digest, SHA256, hashInit, hashUpdate, hashFinalize )+import Data.ByteString (ByteString)+import Data.Dependent.Sum (DSum((:=>)))+import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)+import Data.Time.Clock (UTCTime(..))+import System.Nix.Hash (HashAlgo(HashAlgo_SHA256))+import System.Nix.StorePath (StorePath, parsePath)+import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..))++import Control.Monad.ST+import Data.Default.Class+import Data.STRef+import Data.Word++import Data.ByteString qualified+import System.Nix.Nar qualified++-- | Sample data for an AddToStoreNar operation+data SampleNar+  = SampleNar+  { sampleNar_fileData :: !ByteString -- ^ Contents of the file to be put in the store+  , sampleNar_narData :: !ByteString -- ^ The file data serialized as a NAR+  , sampleNar_storePath :: !StorePath+  , sampleNar_metadata :: !(Metadata StorePath)+  }++sampleNar0 :: IO SampleNar+sampleNar0 = do+  let sampleNar_fileData = "hello"+  sampleNar_narData <- encodeNar sampleNar_fileData+  let sampleNar_metadata = Metadata+        { metadataDeriverPath = Just $ forceParsePath "/nix/store/g2mxdrkwr1hck4y5479dww7m56d1x81v-hello-2.12.1.drv"+        , metadataNarHash = sha256 sampleNar_narData+        , metadataReferences = mempty+        , metadataRegistrationTime = UTCTime (fromOrdinalDate 1980 1) 0+        , metadataNarBytes = Just ((fromIntegral . Data.ByteString.length) sampleNar_narData)+        , metadataTrust = BuiltElsewhere+        , metadataSigs = mempty+        , metadataContentAddress = Nothing+        }+      sampleNar_storePath = forceParsePath "/nix/store/00000lj3clbkc0aqvjjzfa6slp4zdvlj-hello-2.12.1"+  pure SampleNar{..}++buildDataSource :: SampleNar -> IO(Word64 -> IO (Maybe ByteString))+buildDataSource SampleNar{sampleNar_narData} = dataSourceFromByteString sampleNar_narData++dataSourceFromByteString :: ByteString -> IO (Word64 -> IO(Maybe ByteString))+dataSourceFromByteString bs = do+  posRef <- stToIO $ newSTRef (0::Word64)+  let len = fromIntegral $ Data.ByteString.length bs+      outFn chunkSize = do+        pos <- stToIO $ readSTRef posRef+        if pos >= len then pure Nothing+        else do+          let bs' = Data.ByteString.drop (fromIntegral pos) bs+              bs'' = Data.ByteString.take (fromIntegral chunkSize) bs'+              takenLen = fromIntegral $ Data.ByteString.length bs''+          stToIO $ modifySTRef posRef (takenLen +)+          pure $ Just bs''+  pure outFn++forceParsePath :: ByteString -> StorePath+forceParsePath path = case parsePath def path of+  Left err -> error $ mconcat [ "forceParsePath failed: ", show err ]+  Right x -> x+sha256 :: ByteString -> DSum HashAlgo Digest+sha256 bs = HashAlgo_SHA256 :=> hashFinalize (hashUpdate (hashInit @SHA256) bs)++encodeNar :: ByteString -> IO ByteString+encodeNar bytes = do+  ref <- stToIO $ newSTRef mempty+  let accumFn chunk = do+       stToIO $ modifySTRef ref (<> chunk)+  System.Nix.Nar.dumpString bytes accumFn+  stToIO $ readSTRef ref+
+ tests/Data/SerializerSpec.hs view
@@ -0,0 +1,36 @@+module Data.SerializerSpec (spec) where++import Control.Monad.Trans.Identity+import Data.Some+import Data.Serializer+import Data.Serializer.Example++import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec.QuickCheck (prop)++spec :: Spec+spec = describe "Serializer" $ do+  prop "Roundtrips GADT protocol" $ \someCmd ->+    (runG cmdS $ runP cmdS someCmd)+    `shouldBe`+    (pure someCmd ::+      Either (GetSerializerError MyGetError)+        (Some Cmd))++  it "Handles getS error" $+    runG cmdSGetError (runPutS (cmdS @IdentityT) (Some (Cmd_Bool True)))+    `shouldBe`+    Left (SerializerError_Get MyGetError_Example)++  it "Handles getS fail" $+    runG cmdSGetFail (runPutS (cmdS @IdentityT) (Some (Cmd_Bool True)))+    `shouldBe`+    Left (SerializerError_GetFail @MyGetError "Failed reading: no parse\nEmpty call stack\n")++  prop "Roundtrips elaborate example" $ \someCmd readerBool ->+    (runGRest (cmdSRest readerBool) readerBool 0+     $ runPRest (cmdSRest readerBool) someCmd)+    `shouldBe`+    (pure someCmd ::+      Either (GetSerializerError MyGetError)+        (Some Cmd))
tests/Driver.hs view
@@ -1,9 +1,1 @@-import           NixDaemon-import qualified Spec---- we run remote tests in--- Linux namespaces to avoid interacting with systems store-main :: IO ()-main = do-  enterNamespaces-  Spec.main+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/EnumSpec.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE OverloadedStrings #-}++module EnumSpec (spec) where++import Test.Hspec (SpecWith, Spec, describe, it, shouldBe)++import Data.Word (Word64)+import System.Nix.Build (BuildMode(..), BuildSuccessStatus(..), BuildFailureStatus(..))+import System.Nix.Store.Remote.Serializer+  ( activity+  , activityResult+  , enum+  , int+  , loggerOpCode+  , runP+  , workerOp+  , LoggerSError+  , NixSerializer+  , SError+  )+import System.Nix.Store.Remote.Types++spec :: Spec+spec = do+  let+    itE+      :: ( Bounded a+         , Enum a+         , Show a+         )+      => String+      -> a+      -> Word64+      -> SpecWith ()+    itE name constr value =+      it name+        $ runP @SError enum constr+          `shouldBe`+          runP @SError (int @Word64) value++    itE'+      :: Show a+      => NixSerializer LoggerSError a+      -> String+      -> a+      -> Word64+      -> SpecWith ()+    itE' s name constr value =+      it name+        $ runP s constr+          `shouldBe`+          runP @LoggerSError (int @Word64) value++  describe "Enums" $ do+    describe "BuildMode enum order matches Nix" $ do+      itE "Normal" BuildMode_Normal 0+      itE "Repair" BuildMode_Repair 1+      itE "Check"  BuildMode_Check  2++    describe "BuildSuccessStatus enum order matches Nix" $ do+      itE "Built"                  BuildSuccessStatus_Built                   0+      itE "Substituted"            BuildSuccessStatus_Substituted             1+      itE "AlreadyValid"           BuildSuccessStatus_AlreadyValid            2+      itE "ResolvesToAlreadyValid" BuildSuccessStatus_ResolvesToAlreadyValid  3++    describe "BuildFailureStatus enum order matches Nix" $ do+      itE "PermanentFailure"       BuildFailureStatus_PermanentFailure        0+      itE "InputRejected"          BuildFailureStatus_InputRejected           1+      itE "OutputRejected"         BuildFailureStatus_OutputRejected          2+      itE "TransientFailure"       BuildFailureStatus_TransientFailure        3+      itE "CachedFailure"          BuildFailureStatus_CachedFailure           4+      itE "TimedOut"               BuildFailureStatus_TimedOut                5+      itE "MiscFailure"            BuildFailureStatus_MiscFailure             6+      itE "DependencyFailed"       BuildFailureStatus_DependencyFailed        7+      itE "LogLimitExceeded"       BuildFailureStatus_LogLimitExceeded        8+      itE "NotDeterministic"       BuildFailureStatus_NotDeterministic        9+      itE "NoSubstituters"         BuildFailureStatus_NoSubstituters         10+      itE "HashMismatch"           BuildFailureStatus_HashMismatch           11++    describe "GCAction enum order matches Nix" $ do+      itE "ReturnLive"     GCAction_ReturnLive     0+      itE "ReturnDead"     GCAction_ReturnDead     1+      itE "DeleteDead"     GCAction_DeleteDead     2+      itE "DeleteSpecific" GCAction_DeleteSpecific 3++    describe "Logger" $ do+      let itA = itE' activity+      describe "Activity enum order matches Nix" $ do+        itA "CopyPath"      Activity_CopyPath      100+        itA "FileTransfer"  Activity_FileTransfer  101+        itA "Realise"       Activity_Realise       102+        itA "CopyPaths"     Activity_CopyPaths     103+        itA "Builds"        Activity_Builds        104+        itA "Build"         Activity_Build         105+        itA "OptimiseStore" Activity_OptimiseStore 106+        itA "VerifyPaths"   Activity_VerifyPaths   107+        itA "Substitute"    Activity_Substitute    108+        itA "QueryPathInfo" Activity_QueryPathInfo 109+        itA "PostBuildHook" Activity_PostBuildHook 110+        itA "BuildWaiting"  Activity_BuildWaiting  111++      let itR = itE' activityResult+      describe "ActivityResult enum order matches Nix" $ do+        itR "FileLinked"       ActivityResult_FileLinked       100+        itR "BuildLogLine"     ActivityResult_BuildLogLine     101+        itR "UnstrustedPath"   ActivityResult_UnstrustedPath   102+        itR "CorruptedPath"    ActivityResult_CorruptedPath    103+        itR "SetPhase"         ActivityResult_SetPhase         104+        itR "Progress"         ActivityResult_Progress         105+        itR "SetExpected"      ActivityResult_SetExpected      106+        itR "PostBuildLogLine" ActivityResult_PostBuildLogLine 107+++      let itL = itE' loggerOpCode+      describe "LoggerOpCode matches Nix" $ do+        itL "Next"          LoggerOpCode_Next          0x6f6c6d67+        itL "Read"          LoggerOpCode_Read          0x64617461+        itL "Write"         LoggerOpCode_Write         0x64617416+        itL "Last"          LoggerOpCode_Last          0x616c7473+        itL "Error"         LoggerOpCode_Error         0x63787470+        itL "StartActivity" LoggerOpCode_StartActivity 0x53545254+        itL "StopActivity"  LoggerOpCode_StopActivity  0x53544f50+        itL "Result"        LoggerOpCode_Result        0x52534c54++      describe "Verbosity enum order matches Nix" $ do+        itE "Error"     Verbosity_Error     0+        itE "Warn"      Verbosity_Warn      1+        itE "Notice"    Verbosity_Notice    2+        itE "Info"      Verbosity_Info      3+        itE "Talkative" Verbosity_Talkative 4+        itE "Chatty"    Verbosity_Chatty    5+        itE "Debug"     Verbosity_Debug     6+        itE "Vomit"     Verbosity_Vomit     7++      describe "WorkerOp enum order matches Nix" $ do+        let itW name constr value =+              it name+                $ runP workerOp constr+                  `shouldBe`+                  runP @SError (int @Word64) value+        itW "IsValidPath"           WorkerOp_IsValidPath              1+        itW "BuildPathsWithResults" WorkerOp_BuildPathsWithResults   46+        itW "SubmitOutput"          WorkerOp_SubmitOutput          1000+        itW "AddToStoreScanning"    WorkerOp_AddToStoreScanning    1001+++
− tests/NixDaemon.hs 
@@ -1,262 +0,0 @@-{-# language DataKinds           #-}-{-# language ScopedTypeVariables #-}--module NixDaemon where--import qualified System.Environment            as Env-import           Control.Exception              ( bracket )-import           Control.Concurrent             ( threadDelay )-import qualified Data.HashSet                  as HS-import qualified Data.Map.Strict               as M-import           System.Directory-import           System.IO.Temp-import qualified System.Process                as P-import           System.Posix.User             as U-import           System.Linux.Namespaces       as NS-import           Test.Hspec                     ( Spec-                                                , describe-                                                , context-                                                )-import qualified Test.Hspec                    as Hspec-import           Test.Hspec.Expectations.Lifted--import           System.FilePath--import           System.Nix.Build-import           System.Nix.StorePath-import           System.Nix.Store.Remote-import           System.Nix.Store.Remote.Protocol--import           Crypto.Hash                    ( SHA256 )-import           System.Nix.Nar                 ( dumpPath )--createProcessEnv :: FilePath -> String -> [String] -> IO P.ProcessHandle-createProcessEnv fp proc args = do-  mPath         <- Env.lookupEnv "PATH"--  (_, _, _, ph) <--    P.createProcess (P.proc proc args)-      { P.cwd = Just fp-      , P.env = Just $ mockedEnv mPath fp-      }-  pure ph--mockedEnv :: Maybe String -> FilePath -> [(String, FilePath)]-mockedEnv mEnvPath fp = (fp </>) <<$>>-  [ ("NIX_STORE_DIR"     , "store")-  , ("NIX_LOCALSTATE_DIR", "var")-  , ("NIX_LOG_DIR"       , "var" </> "log")-  , ("NIX_STATE_DIR"     , "var" </> "nix")-  , ("NIX_CONF_DIR"      , "etc")-  , ("HOME"              , "home")---  , ("NIX_REMOTE", "daemon")-    ] <> foldMap (\x -> [("PATH", x)]) mEnvPath--waitSocket :: FilePath -> Int -> IO ()-waitSocket _  0 = fail "No socket"-waitSocket fp x = do-  ex <- doesFileExist fp-  bool-    (threadDelay 100000 >> waitSocket fp (x - 1))-    pass-    ex--writeConf :: FilePath -> IO ()-writeConf fp =-  writeFileText 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-  -> IO (P.ProcessHandle, MonadStore a -> IO (Either String a, [Logger]))-startDaemon fp = do-  writeConf (fp </> "etc" </> "nix.conf")-  p <- createProcessEnv fp "nix-daemon" []-  waitSocket sockFp 30-  pure (p, runStoreOpts sockFp (fp </> "store"))- where-  sockFp = fp </> "var/nix/daemon-socket/socket"--enterNamespaces :: IO ()-enterNamespaces = do-  uid <- getEffectiveUserID-  gid <- getEffectiveGroupID--  unshare [User, Network, Mount]-  -- fmap our (parent) uid to root-  writeUserMappings Nothing [UserMapping 0 uid 1]-  -- fmap our (parent) gid to root group-  writeGroupMappings Nothing [GroupMapping 0 gid 1] True--withNixDaemon-  :: ((MonadStore a -> IO (Either String a, [Logger])) -> IO a) -> IO a-withNixDaemon action =-  withSystemTempDirectory "test-nix-store" $ \path -> do--    mapM_ (createDirectory . snd)-          (filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path)--    ini <- createProcessEnv path "nix-store" ["--init"]-    void $ P.waitForProcess ini--    writeFile (path </> "dummy") "Hello World"--    setCurrentDirectory path--    bracket (startDaemon path)-            (P.terminateProcess . fst)-            (action . snd)--checks :: (Show a, Show b) => IO (a, b) -> (a -> Bool) -> IO ()-checks action check = action >>= (`Hspec.shouldSatisfy` (check . fst))--it-  :: (Show a, Show b, Monad m)-  => String-  -> m c-  -> (a -> Bool)-  -> Hspec.SpecWith (m () -> IO (a, b))-it name action check =-  Hspec.it name $ \run -> run (action >> pass) `checks` check--itRights-  :: (Show a, Show b, Show c, Monad m)-  => String-  -> m d-  -> Hspec.SpecWith (m () -> IO (Either a b, c))-itRights name action = it name action isRight--itLefts-  :: (Show a, Show b, Show c, Monad m)-  => String-  -> m d-  -> Hspec.SpecWith (m () -> IO (Either a b, c))-itLefts name action = it name action isLeft--withPath :: (StorePath -> MonadStore a) -> MonadStore a-withPath action = do-  path <- addTextToStore "hnix-store" "test" (HS.fromList []) False-  action path---- | dummy path, adds <tmp>/dummpy with "Hello World" contents-dummy :: MonadStore StorePath-dummy = do-  let Right n = makeStorePathName "dummy"-  addToStore @SHA256 n (dumpPath "dummy") False False--invalidPath :: StorePath-invalidPath =-  let Right n = makeStorePathName "invalid"-  in  StorePath (mkStorePathHashPart "invalid") n "no_such_root"--withBuilder :: (StorePath -> MonadStore a) -> MonadStore a-withBuilder action = do-  path <- addTextToStore "builder" builderSh (HS.fromList []) False-  action path--builderSh :: Text-builderSh = "declare -xpexport > $out"--spec_protocol :: Spec-spec_protocol = Hspec.around withNixDaemon $--  describe "store" $ do--    context "syncWithGC" $-      itRights "syncs with garbage collector" syncWithGC--    context "verifyStore" $ do-      itRights "check=False repair=False" $-        verifyStore False False `shouldReturn` False--      itRights "check=True repair=False" $-        verifyStore True False `shouldReturn` False--      --privileged-      itRights "check=True repair=True" $-        verifyStore True True `shouldReturn` False--    context "addTextToStore" $-      itRights "adds text to store" $ withPath pure--    context "isValidPathUncached" $ do-      itRights "validates path" $ withPath $ \path -> do-        liftIO $ print path-        isValidPathUncached path `shouldReturn` True-      itLefts "fails on invalid path" $ isValidPathUncached invalidPath--    context "queryAllValidPaths" $ do-      itRights "empty query" queryAllValidPaths-      itRights "non-empty query" $ withPath $ \path ->-        queryAllValidPaths `shouldReturn` HS.fromList [path]--    context "queryPathInfoUncached" $-      itRights "queries path info" $ withPath queryPathInfoUncached--    context "ensurePath" $-      itRights "simple ensure" $ withPath ensurePath--    context "addTempRoot" $-      itRights "simple addition" $ withPath addTempRoot--    context "addIndirectRoot" $-      itRights "simple addition" $ withPath addIndirectRoot--    context "buildPaths" $ do-      itRights "build Normal" $ withPath $ \path -> do-        let pathSet = HS.fromList [path]-        buildPaths pathSet Normal--      itRights "build Check" $ withPath $ \path -> do-        let pathSet = HS.fromList [path]-        buildPaths pathSet Check--      itLefts "build Repair" $ withPath $ \path -> do-        let pathSet = HS.fromList [path]-        buildPaths pathSet Repair--    context "roots" $ context "findRoots" $ do-        itRights "empty roots" (findRoots `shouldReturn` M.empty)--        itRights "path added as a temp root" $ withPath $ \_ -> do-          roots <- findRoots-          roots `shouldSatisfy` ((== 1) . M.size)--    context "optimiseStore" $ itRights "optimises" optimiseStore--    context "queryMissing" $-      itRights "queries" $ withPath $ \path -> do-        let pathSet = HS.fromList [path]-        queryMissing pathSet `shouldReturn` (HS.empty, HS.empty, HS.empty, 0, 0)--    context "addToStore" $-      itRights "adds file to store" $ do-        fp <- liftIO $ writeSystemTempFile "addition" "lal"-        let Right n = makeStorePathName "tmp-addition"-        res <- addToStore @SHA256 n (dumpPath fp) False False-        liftIO $ print res--    context "with dummy" $ do-      itRights "adds dummy" dummy--      itRights "valid dummy" $ do-        path <- dummy-        liftIO $ print path-        isValidPathUncached path `shouldReturn` True
+ tests/NixSerializerSpec.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE OverloadedStrings #-}++module NixSerializerSpec (spec) where++import Crypto.Hash (MD5, SHA1, SHA256, SHA512)+import Data.Set qualified+import Data.Some (Some)+import Data.Time (UTCTime)+import Test.Hspec (Expectation, Spec, describe, parallel, shouldBe)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Gen, arbitrary, forAll, suchThat)++import System.Nix.Arbitrary ()+import System.Nix.Build (BuildResult(..), BuildSuccess(..))+import System.Nix.Derivation.Traditional qualified+import System.Nix.Store.Remote.Arbitrary ()+import System.Nix.Store.Remote.Serializer+import System.Nix.Store.Remote.Types.Logger ()+import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ProtoFeature(..))+import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))++-- | Test for roundtrip using @NixSerializer@+roundtripS+  :: forall e a+   . ( Eq a+     , Show a+     , Eq e+     , Show e+     )+  => NixSerializer e a+  -> a+  -> Expectation+roundtripS serializer a =+    runG serializer (runP serializer a)+    `shouldBe` Right a++spec :: Spec+spec = parallel $ do+  describe "Prim" $ do+    prop "Int" $ roundtripS @() @Int int+    prop "Bool" $ roundtripS bool+    prop "ByteString" $ roundtripS byteString+    prop "Text" $ roundtripS text+    prop "Maybe Text" $ roundtripS maybeText+    prop "UTCTime" $ roundtripS @() @UTCTime time++  describe "Combinators" $ do+    prop "list" $ roundtripS @() @[Int] (list int)+    prop "set" $ roundtripS (set byteString)+    prop "hashSet" $ roundtripS (hashSet byteString)+    prop "mapS" $ roundtripS (mapS (int @Int) byteString)++  describe "Complex" $ do+    prop "DSum HashAlgo Digest" $ roundtripS namedDigest++    prop "BuildResult"+      $ \sd pv ->+          let pv' = pv { protoVersion_features = Data.Set.singleton ProtoFeature_RealisationWithPathNotHash }+          in roundtripS (buildResult sd pv')+          . (\x -> x { buildResultStatus = case buildResultStatus x of+                        Right (BuildSuccess st _bo) -> Right (BuildSuccess st mempty)+                        Left f -> Left f+                     })+          . (\x -> x { buildResultCpuUser = Nothing+                     , buildResultCpuSystem = Nothing+                     }+            )++    prop "StorePath" $ \sd ->+      roundtripS (storePath sd)++    prop "StorePathHashPart" $+      roundtripS storePathHashPart++    prop "StorePathName" $+      roundtripS storePathName++    prop "Metadata (StorePath)" $ \sd ->+      roundtripS (pathMetadata sd)++    prop "Some HashAlgo" $+      roundtripS someHashAlgo++    describe "Digest" $ do+      prop "MD5" $ roundtripS . digest @MD5+      prop "SHA1" $ roundtripS . digest @SHA1+      prop "SHA256" $ roundtripS . digest @SHA256+      prop "SHA512" $ roundtripS . digest @SHA512++    prop "Derivation" $ \sd drv ->+      roundtripS (basicDerivation sd) $+        System.Nix.Derivation.Traditional.withoutName drv++    prop "SingleDerivedPath" $ \sd ->+      roundtripS (singleDerivedPath sd)++    prop "ProtoVersion" $ roundtripS @() @ProtoVersion protoVersion++    prop "ProtoFeature" $ roundtripS protoFeature+    prop "Set ProtoFeature" $ roundtripS protoFeatures++    describe "Logger" $ do+      prop "ActivityID" $ roundtripS activityID+      prop "Maybe Activity" $ roundtripS maybeActivity+      prop "ActivityResult" $ roundtripS activityResult+      prop "Field" $ roundtripS field+      prop "Trace" $ roundtripS trace+      prop "ErrorInfo" $ roundtripS errorInfo+      prop "LoggerOpCode" $ roundtripS loggerOpCode+      prop "Verbosity" $ roundtripS verbosity+      prop "Logger"+        $ forAll (arbitrary :: Gen ProtoVersion)+        $ \pv -> roundtripS (logger pv)++  describe "Handshake" $ do+    prop "WorkerMagic" $ roundtripS workerMagic+    prop "TrustedFlag" $ roundtripS trustedFlag++  describe "Worker protocol" $ do+    prop "WorkerOp" $ roundtripS workerOp+    prop "StoreText" $ roundtripS storeText++    prop "StoreRequest"+      $ \sd -> forAll arbitrary $ \pv ->+          forAll (arbitrary `suchThat` (restrictProtoVersion pv))+          $ roundtripS (storeRequest sd pv)++  describe "StoreReply" $ do+    prop "()" $ roundtripS opSuccess+    prop "GCResult" $ \sd -> roundtripS (gcResult sd)+    prop "GCRoot" $ roundtripS gcRoot+    prop "Missing" $ \sd -> roundtripS (missing sd)+    prop "Maybe (Metadata StorePath)" $ \sd -> roundtripS (maybePathMetadata sd)++restrictProtoVersion :: ProtoVersion -> Some StoreRequest -> Bool+restrictProtoVersion _ _ = True+
− tests/Spec.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Spec #-}
− tests/Util.hs 
@@ -1,12 +0,0 @@--module Util where--import           Data.Text.Arbitrary ()-import           System.Nix.Store.Remote.Util-import           Test.Tasty.QuickCheck--prop_TextToBSLRoundtrip :: Text -> Property-prop_TextToBSLRoundtrip x = bslToText (textToBSL x) === x--prop_TextToBSRoundtrip :: Text -> Property-prop_TextToBSRoundtrip x = bsToText (textToBS x) === x