hnix-store-remote 0.7.0.0 → 0.8.0.0

raw patch · 27 files changed

+2354/−2029 lines, 27 filesdep +hnix-store-atermdep +latticesdep +mmorphdep ~hnix-store-coredep ~hnix-store-jsondep ~hnix-store-tests

Dependencies added: hnix-store-aterm, lattices, mmorph

Dependency ranges changed: hnix-store-core, hnix-store-json, hnix-store-tests

Files

• CHANGELOG.md +21/−0
• app/BuildDerivation.hs +5/−5
• hnix-store-remote.cabal +14/−8
• src/Data/Serializer.hs +52/−36
• src/Data/Serializer/Example.hs +26/−72
• src/System/Nix/Store/Remote.hs +5/−5
• src/System/Nix/Store/Remote/Arbitrary.hs +20/−8
• src/System/Nix/Store/Remote/Client.hs +82/−17
• src/System/Nix/Store/Remote/Client/Core.hs +87/−37
• src/System/Nix/Store/Remote/Logger.hs +6/−6
• src/System/Nix/Store/Remote/MonadStore.hs +5/−4
• src/System/Nix/Store/Remote/Serializer.hs +1596/−1555
• src/System/Nix/Store/Remote/Server.hs +141/−65
• src/System/Nix/Store/Remote/Socket.hs +10/−17
• src/System/Nix/Store/Remote/Types/Handshake.hs +4/−4
• src/System/Nix/Store/Remote/Types/Logger.hs +1/−9
• src/System/Nix/Store/Remote/Types/ProtoVersion.hs +77/−2
• src/System/Nix/Store/Remote/Types/StoreConfig.hs +1/−1
• src/System/Nix/Store/Remote/Types/StoreReply.hs +16/−16
• src/System/Nix/Store/Remote/Types/StoreRequest.hs +36/−9
• src/System/Nix/Store/Remote/Types/WorkerOp.hs +24/−2
• tests-io/Main.hs +2/−2
• tests-io/NixDaemonSpec.hs +25/−22
• tests-io/SampleNar.hs +2/−2
• tests/Data/SerializerSpec.hs +12/−19
• tests/EnumSpec.hs +36/−26
• tests/NixSerializerSpec.hs +48/−80

@@ -1,3 +1,24 @@+# [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:

@@ -3,11 +3,11 @@  import Data.Default.Class (Default(def)) -import qualified Data.Text-import qualified System.Environment-import qualified System.Nix.Build-import qualified System.Nix.StorePath-import qualified System.Nix.Store.Remote+import Data.Text qualified+import System.Environment qualified+import System.Nix.Build qualified+import System.Nix.StorePath qualified+import System.Nix.Store.Remote qualified  main :: IO () main = System.Environment.getArgs >>= \case

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                hnix-store-remote-version:             0.7.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@@ -31,6 +31,7 @@     , DerivingVia     , FlexibleContexts     , FlexibleInstances+    , ImportQualifiedPost     , GADTs     , RecordWildCards     , ScopedTypeVariables@@ -103,10 +104,11 @@    build-depends:       base >=4.12 && <5-    , hnix-store-core >= 0.8 && <0.9-    , hnix-store-json >= 0.1+    , hnix-store-core >= 0.9 && <0.10+    , hnix-store-json >= 0.2     , hnix-store-nar >= 0.1-    , hnix-store-tests >= 0.1+    , hnix-store-tests >= 0.2+    , hnix-store-aterm     , aeson     , attoparsec     , bytestring@@ -122,6 +124,8 @@     , exceptions     , generic-arbitrary < 1.1     , hashable+    , lattices+    , mmorph     , text     , time     , transformers@@ -135,6 +139,7 @@   ghc-options:         -Wall  executable build-derivation+  import: commons   if !flag(build-derivation)     buildable: False   build-depends:@@ -143,12 +148,12 @@     , hnix-store-remote     , data-default-class     , text-  default-language: Haskell2010   main-is: BuildDerivation.hs   hs-source-dirs:      app   ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N"  executable remote-readme+  import: commons   if !flag(build-readme)     buildable: False   build-depends:@@ -157,7 +162,6 @@     , hnix-store-remote   build-tool-depends:       markdown-unlit:markdown-unlit-  default-language: Haskell2010   main-is: README.lhs   ghc-options: -pgmL markdown-unlit -Wall @@ -178,12 +182,14 @@     , hnix-store-core     , hnix-store-remote     , hnix-store-tests-    , bytestring+    , hnix-store-aterm+    , containers     , crypton     , some > 1.0.5 && < 2-    , time     , hspec     , QuickCheck+    , time+    , transformers  test-suite remote-io   import: commons

@@ -29,18 +29,19 @@   , SimpleSerializer   -- ** Simple runners   , runGetSimple-  , runPutSimple   -- * From Get/Put, Serialize   , lift2   , liftSerialize   -- * Combinators+  , AlmostPrism(..)+  , maybeAlmostPrism   , mapIsoSerializer   , mapPrismSerializer   , tup+  , depTup   -- * Utility   , GetSerializerError(..)   , transformGetError-  , transformPutError   -- * Re-exports   , Get   , PutM@@ -49,16 +50,15 @@ #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) #endif-import Control.Monad.Except (MonadError, throwError)-import Control.Monad.Trans (lift)-import Control.Monad.Trans (MonadTrans)+import Control.Monad.Morph import Control.Monad.Trans.Identity (IdentityT, runIdentityT) import Data.ByteString (ByteString)+import Data.Functor.Identity import Data.Serialize (Serialize)+import Data.Serialize qualified import Data.Serialize.Get (Get, runGet) import Data.Serialize.Put (Putter, PutM, runPutM) -import qualified Data.Serialize  -- * Serializer @@ -68,21 +68,17 @@ -- for e.g. adding @ExceptT@ or @ReaderT@ layers. data Serializer t a = Serializer   { getS :: t Get a-  , putS :: a -> t PutM ()+  , putS :: a -> PutM ()   }  -- ** Runners  -- | Runner for putS of @Serializer@ runPutS-  :: ( Monad (t PutM)-     , MonadTrans t-     )-  => Serializer t a        -- ^ Serializer-  -> (t PutM () -> PutM b) -- ^ Tranformer runner+  :: Serializer t a        -- ^ Serializer   -> a                     -- ^ Value to (out)put-  -> (b, ByteString)-runPutS s run a = runPutM $ run $ (putS s) a+  -> ByteString+runPutS s = snd . runPutM . putS s  -- | Runner for getS of @Serializer@ runGetS@@ -110,15 +106,6 @@ runGetSimple s b =   runGetS s (runIdentityT) b --- | Runner for putS of @SimpleSerializer@-runPutSimple-  :: SimpleSerializer a-  -> a-  -> ByteString-runPutSimple s =-    snd-  . runPutS s runIdentityT- -- * From Get/Put, Serialize  -- | Lift @Get a@ and @Putter a@ into @Serializer@@@ -130,7 +117,7 @@   -> Serializer t a lift2 f g = Serializer   { getS = lift f-  , putS = lift . g+  , putS = g   }  -- | Lift @Serialize a@ instance into @Serializer@@@ -158,17 +145,34 @@   , putS = putS s . g   } +data AlmostPrism t a b = AlmostPrism+  { _almostPrism_get :: a -> t Identity b+  -- ^ Map over @getS@+  , _almostPrism_put :: b -> a+  -- ^ Map over @putS@+  }++maybeAlmostPrism+  :: Applicative (t Identity)+  => AlmostPrism t a b+  -> AlmostPrism t (Maybe a) (Maybe b)+maybeAlmostPrism ap = AlmostPrism+  { _almostPrism_get = traverse $ _almostPrism_get ap+  , _almostPrism_put = fmap $ _almostPrism_put ap+  }+ -- | Map over @Serializer@ where @getS@ -- can return @Either@ mapPrismSerializer-  :: MonadError eGet (t Get)-  => (a -> Either eGet b) -- ^ Map over @getS@-  -> (b -> a)             -- ^ Map over @putS@+  :: ( Monad (t Get)+     , MFunctor t+     )+  => AlmostPrism t a b   -> Serializer t a   -> Serializer t b-mapPrismSerializer f g s = Serializer-  { getS = either throwError pure . f =<< getS s-  , putS = putS s . g+mapPrismSerializer p s = Serializer+  { getS = hoist generalize . _almostPrism_get p =<< getS s+  , putS = putS s . _almostPrism_put p   }  -- | Tuple combinator@@ -186,6 +190,24 @@       putS b y   } +-- | Dependent tuple combinator+depTup+  :: ( Monad (t Get)+     , Monad (t PutM)+     )+  => Serializer t a+  -> (a -> Serializer t b)+  -> Serializer t (a, b)+depTup sa sb = Serializer+  { getS = do+    a <- getS sa+    b <- getS $ sb a+    pure (a, b)+  , putS = \(x, y) -> do+      putS sa x+      putS (sb x) y+  }+ -- * Utilities  -- | Wrapper for both GetS errors@@ -206,9 +228,3 @@   Left stringyRunGetError -> Left (SerializerError_GetFail stringyRunGetError)   Right (Left myGetError) -> Left (SerializerError_Get myGetError)   Right (Right res) -> Right res---- | Helper for transforming @runPutM@ result-transformPutError-  :: (Either customPutError (), ByteString)-  -> Either customPutError ByteString-transformPutError (e, r) = either Left (pure $ Right r) e

@@ -11,16 +11,11 @@   , runP   -- * Custom errors   , MyGetError(..)-  , MyPutError(..)   -- ** Erroring variants of cmdS-  -- *** putS with throwError and MyPutError-  , cmdSPutError   -- *** getS with throwError and MyGetError   , cmdSGetError   -- *** getS with fail   , cmdSGetFail-  -- *** putS with fail-  , cmdSPutFail   -- * Elaborate   , cmdSRest   , runGRest@@ -28,13 +23,13 @@   ) where  import Control.Monad.Except (MonadError, throwError)-import Control.Monad.Reader (MonadReader, ask)+import Control.Monad.Reader (MonadReader) import Control.Monad.State (MonadState) import Control.Monad.Trans (MonadTrans, lift) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.State (StateT, runStateT)-import Data.Bifunctor (first, second)+import Data.Bifunctor (second) import Data.ByteString (ByteString) import Data.Int (Int8) import Data.GADT.Show (GShow(..), defaultGshowsPrec)@@ -48,7 +43,6 @@   , runGetS   , runPutS   , transformGetError-  , transformPutError   ) import Data.Some (Some(..)) import GHC.Generics (Generic)@@ -97,25 +91,25 @@ opcode :: MonadTrans t => Serializer t OpCode opcode = Serializer   { getS = lift getEnum-  , putS = lift . putEnum+  , putS = putEnum   }  -- * Cmd Serializer  -- | @Cmd@ @Serializer@ cmdS-  :: forall t . ( MonadTrans t-     , Monad (t Get)-     , Monad (t PutM)-     )+  :: forall t+  . ( MonadTrans t+    , Monad (t Get)+    )   => Serializer t (Some Cmd) cmdS = Serializer   { getS = getS opcode >>= \case       OpCode_Int -> Some . Cmd_Int <$> lift getInt8       OpCode_Bool -> Some . Cmd_Bool <$> lift getBool   , putS = \case-      Some (Cmd_Int i) -> putS opcode OpCode_Int >> lift (putInt8 i)-      Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b)+      Some (Cmd_Int i) -> putS (opcode @t) OpCode_Int >> putInt8 i+      Some (Cmd_Bool b) -> putS (opcode @t) OpCode_Bool >> putBool b   }  -- * Runners@@ -133,10 +127,8 @@ runP   :: Serializer (ExceptT e) a   -> a-  -> Either e ByteString-runP s =-   (\(e, r) -> either Left (pure $ Right r) e)-  . runPutS s runExceptT+  -> ByteString+runP = runPutS  -- * Custom errors @@ -144,22 +136,8 @@   = MyGetError_Example   deriving (Eq, Show) -data MyPutError-  = MyPutError_NoLongerSupported -- no longer supported protocol version-  deriving (Eq, Show)- -- ** Erroring variants of cmdS --- *** putS with throwError and MyPutError--cmdSPutError :: Serializer (ExceptT MyPutError) (Some Cmd)-cmdSPutError = Serializer-  { getS = getS cmdS-  , putS = \case-      Some (Cmd_Int i) -> putS opcode OpCode_Int >> lift (putInt8 i)-      Some (Cmd_Bool _b) -> throwError MyPutError_NoLongerSupported-  }- -- *** getS with throwError and MyGetError  cmdSGetError :: Serializer (ExceptT MyGetError) (Some Cmd)@@ -167,13 +145,14 @@   { getS = getS opcode >>= \case       OpCode_Int -> Some . Cmd_Int <$> lift getInt8       OpCode_Bool -> throwError MyGetError_Example-  , putS = putS cmdS+  , putS = putS $ cmdS @(ExceptT MyGetError)   }  -- *** getS with fail  cmdSGetFail-  :: ( MonadTrans t+  :: forall t+  .  ( MonadTrans t      , MonadFail (t Get)      , Monad (t PutM)      )@@ -182,26 +161,7 @@   { getS = getS opcode >>= \case       OpCode_Int -> Some . Cmd_Int <$> lift getInt8       OpCode_Bool -> fail "no parse"-  , putS = putS cmdS-  }---- *** putS with fail---- | Unused as PutM doesn't have @MonadFail@--- >>> serializerPutFail = cmdPutFail @(ExceptT MyGetError)--- No instance for (MonadFail PutM)--- as expected-cmdSPutFail-  :: ( MonadTrans t-     , MonadFail (t PutM)-     , Monad (t Get)-     )-  => Serializer t (Some Cmd)-cmdSPutFail = Serializer-  { getS = getS cmdS-  , putS = \case-      Some (Cmd_Int i) -> putS opcode OpCode_Int >> lift (putInt8 i)-      Some (Cmd_Bool _b) -> fail "can't"+  , putS = putS $ cmdS @t   }  -- * Elaborate@@ -250,35 +210,29 @@  runPRest   :: Serializer (REST r e s) a-  -> r-  -> s   -> a-  -> Either e ByteString-runPRest serializer r s =-    transformPutError-  . first fst-  . runPutS-      serializer-      (restRunner r s)+  -> ByteString+runPRest = runPutS  cmdSRest-  :: Serializer (REST Bool e Int) (Some Cmd)-cmdSRest = Serializer+  :: forall t e+  .  t ~ REST Bool e Int+  => Bool+  -> Serializer t (Some Cmd)+cmdSRest isTrue = Serializer   { getS = getS opcode >>= \case       OpCode_Int -> do-        isTrue <- ask         if isTrue         then Some . Cmd_Int . (+1) <$> lift getInt8         else Some . Cmd_Int <$> lift getInt8       OpCode_Bool -> Some . Cmd_Bool <$> lift getBool   , putS = \case       Some (Cmd_Int i) -> do-        putS opcode OpCode_Int-        isTrue <- ask+        putS (opcode @t) OpCode_Int         if isTrue-        then lift (putInt8 (i - 1))-        else lift (putInt8 i)-      Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b)+        then putInt8 (i - 1)+        else putInt8 i+      Some (Cmd_Bool b) -> putS (opcode @t) OpCode_Bool >> putBool b   }  -- Primitives helpers

@@ -23,7 +23,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Default.Class (Default(def)) import Network.Socket (Family, SockAddr(SockAddrUnix))-import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))+import System.Nix.Store.Types (RepairMode(..)) import System.Nix.Store.Remote.MonadStore   ( runRemoteStoreT   , MonadRemoteStore(..)@@ -33,14 +33,14 @@ import System.Nix.Store.Remote.Server (WorkerHelper, runProxyDaemon) import System.Nix.Store.Remote.Types -import qualified Control.Monad.Catch-import qualified Network.Socket+import Control.Monad.Catch qualified+import Network.Socket qualified -- see TODO bellow---import qualified System.Directory+--import System.Directory qualified  -- wip justdoit import System.Nix.StorePath (StorePath)-import qualified System.Nix.StorePath+import System.Nix.StorePath qualified  -- * Compat 

@@ -5,10 +5,12 @@  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(..), oneof, suchThat)+import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum, oneof, suchThat) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))  deriving via GenericArbitrary CheckMode@@ -20,9 +22,14 @@ deriving via GenericArbitrary ProtoStoreConfig   instance Arbitrary ProtoStoreConfig -deriving via GenericArbitrary ProtoVersion-  instance Arbitrary ProtoVersion+-- 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 @@ -48,9 +55,6 @@      pure Trace{..} -deriving via GenericArbitrary BasicError-  instance Arbitrary BasicError- instance Arbitrary ErrorInfo where   arbitrary = do     errorInfoLevel <- arbitrary@@ -95,13 +99,20 @@  instance Arbitrary (Some StoreRequest) where   arbitrary = oneof-    [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair)+    [ 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)-    , Some <$> (BuildDerivation <$> arbitrary <*> arbitrary <*> arbitrary)+    , do+        path <- arbitrary+        drv <- arbitrary+        buildMode' <- arbitrary+        -- Ensure store path name matches derivation name (helps with length issues)+        let path' = path { storePathName = name drv }+        pure $ Some (BuildDerivation path' drv buildMode')     , Some . CollectGarbage <$> arbitrary     , Some . EnsurePath <$> arbitrary     , pure $ Some FindRoots@@ -118,6 +129,7 @@     , Some . QueryPathFromHashPart <$> arbitrary     , Some . QueryMissing <$> arbitrary     , pure $ Some OptimiseStore+    , Some <$> (SubmitOutput <$> arbitrary <*> arbitrary)     , pure $ Some SyncWithGC     , Some <$> (VerifyStore <$> arbitrary <*> arbitrary)     ]

@@ -1,6 +1,7 @@ module System.Nix.Store.Remote.Client   ( addToStore   , addToStoreNar+  , addToStoreScanning   , addTextToStore   , addSignatures   , addTempRoot@@ -23,6 +24,7 @@   , queryPathFromHashPart   , queryMissing   , optimiseStore+  , submitOutput   , syncWithGC   , verifyStore   , module System.Nix.Store.Remote.Client.Core@@ -38,44 +40,65 @@ import Data.Word (Word64)  import System.Nix.Build (BuildMode, BuildResult)-import System.Nix.DerivedPath (DerivedPath)+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.Store.Types (FileIngestionMethod(..), RepairMode(..))+import System.Nix.ContentAddress (ContentAddressMethod)+import System.Nix.Store.Types (RepairMode(..)) -import qualified Control.Monad.IO.Class-import qualified Data.Attoparsec.Text-import qualified Data.Text.IO-import qualified System.Nix.Derivation-import qualified System.Nix.StorePath+import Control.Monad.IO.Class qualified+import Data.Attoparsec.Text qualified+import Data.Text.IO qualified+import System.Nix.Derivation qualified+import System.Nix.StorePath qualified  -- | Add `NarSource` to the store addToStore   :: MonadRemoteStore m   => StorePathName        -- ^ Name part of the newly created `StorePath`   -> NarSource IO         -- ^ Provide nar stream-  -> FileIngestionMethod  -- ^ Add target directory recursively-  -> Some HashAlgo        -- ^-  -> RepairMode           -- ^ Only used by local store backend+  -> 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 repair = do-  Control.Monad.when-    (repair == RepairMode_DoRepair)-    $ throwError RemoteStoreError_RapairNotSupportedByRemoteStore+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 (AddToStore name method hashAlgo repair)+  doReq (AddToStoreScanning name method hashAlgo)  addToStoreNar   :: MonadRemoteStore m@@ -144,9 +167,24 @@     $ Data.Text.IO.readFile     $ System.Nix.StorePath.storePathToFilePath sd sp   case Data.Attoparsec.Text.parseOnly-    (System.Nix.Derivation.parseDerivation sd) drvContents of+    (System.Nix.Derivation.ATerm.parseTraditionalDerivation sd) drvContents of       Left e -> throwError $ RemoteStoreError_DerivationParse e-      Right drv -> doReq (BuildDerivation sp drv mode)+      Right drv -> do+        let name = System.Nix.StorePath.storePathName sp+        outputs <- case+          System.Nix.Derivation.toSpecificOutputs sd name $+            System.Nix.Derivation.Traditional.anonOutputs drv+          of+           Nothing -> throwError $ RemoteStoreError_DerivationParse "TODO get error"+           Just os -> pure os+        let drv' = System.Nix.Derivation.Traditional.withName name $+              drv+                { System.Nix.Derivation.Traditional.anonOutputs = outputs+                , System.Nix.Derivation.Traditional.anonInputs =+                    System.Nix.Derivation.Traditional.traditionalSrcs+                      (System.Nix.Derivation.Traditional.anonInputs drv)+                }+        doReq (BuildDerivation sp drv' mode)  -- | Build paths if they are an actual derivations. --@@ -266,10 +304,37 @@   => 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

@@ -4,11 +4,14 @@   , 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)@@ -24,7 +27,9 @@   ( bool   , int   , mapErrorS+  , protoFeatures   , protoVersion+  , validPathInfo   , storeRequest   , text   , trustedFlag@@ -33,13 +38,13 @@ import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeOutput(..)) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.NoReply (NoReply(..))-import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..))+import System.Nix.Store.Remote.Types.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 qualified Data.ByteString-import qualified Network.Socket.ByteString+import Data.ByteString qualified+import Network.Socket.ByteString qualified  type Run m a = m (Either RemoteStoreError a, DList Logger) @@ -55,28 +60,46 @@   -> m a doReq = \case   x -> do+    storeDir <- getStoreDir+    pv <- getProtoVersion     sockPutS       (mapErrorS         RemoteStoreError_SerializerRequest-          storeRequest+          (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) -> do-            soc <- getStoreSocket-            liftIO-              $ stream-              $ Network.Socket.ByteString.sendAll soc+          Just (stream :: NarSource IO) ->+            liftIO $ writeFramedNarSource stream soc           Nothing ->             throwError               RemoteStoreError_NoNarSourceProvided         processOutput-        processReply+        (path, _metadata) <- sockGetS+          $ mapErrorS RemoteStoreError_SerializerGet+          $ validPathInfo storeDir+        pure path        AddToStoreNar _ meta _ _ -> do         let narBytes = maybe 0 id $ metadataNarBytes meta@@ -112,9 +135,12 @@         processReply    where-    processReply = sockGetS+    processReply = do+      storeDir <- getStoreDir+      pv <- getProtoVersion+      sockGetS           (mapErrorS RemoteStoreError_SerializerReply-            $ getReplyS @a+            $ getReplyS @a storeDir pv           )  copyToSink@@ -135,6 +161,29 @@     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@@ -185,45 +234,46 @@    daemonVersion <- sockGetS protoVersion -  when (daemonVersion < ProtoVersion 1 10)+  when (not (ProtoVersion 1 37 mempty `leq` daemonVersion))     $ throwError RemoteStoreError_ClientVersionTooOld    pv <- getProtoVersion   sockPutS protoVersion pv -  let leastCommonVersion = min daemonVersion pv+  let leastCommonVersion = minVersionNumber daemonVersion pv -  when (leastCommonVersion >= ProtoVersion 1 14)-    $ sockPutS int (0 :: Int) -- affinity, obsolete+  -- 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 -  when (leastCommonVersion >= ProtoVersion 1 11) $ do-    sockPutS-      (mapErrorS RemoteStoreError_SerializerPut bool)-      False -- reserveSpace, obsolete+  let leastCommonVersionWithFeatures = leastCommonVersion { protoVersion_features = negotiatedFeatures } -  daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33-    then do-      -- If we were buffering I/O, we would flush the output here.-      txtVer <--        sockGetS-          $ mapErrorS-              RemoteStoreError_SerializerGet-              text-      pure $ Just txtVer-    else pure Nothing+  setProtoVersion leastCommonVersionWithFeatures -  remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35-    then do-      sockGetS-        $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag-    else pure Nothing+  -- postHandshake: affinity (obsolete), reserveSpace (obsolete)+  sockPutS int (0 :: Int) -- affinity, obsolete+  sockPutS (mapErrorS RemoteStoreError_SerializerPut bool) False -- reserveSpace, obsolete -  setProtoVersion leastCommonVersion+  -- 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 = leastCommonVersion+    , clientHandshakeOutputLeastCommonVersion = leastCommonVersionWithFeatures     , clientHandshakeOutputServerVersion = daemonVersion     }

@@ -6,16 +6,16 @@ import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import Data.Serialize (Result(..))-import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT)+import System.Nix.Store.Remote.Serializer (LoggerSError, logger, 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 qualified Control.Monad-import qualified Data.Serialize.Get-import qualified Data.Serializer-import qualified Network.Socket.ByteString+import Control.Monad qualified+import Data.Serialize.Get qualified+import Data.Serializer qualified+import Network.Socket.ByteString qualified  processOutput   :: MonadRemoteStore m@@ -30,7 +30,7 @@     -> Result (Either LoggerSError Logger)   decoder protoVersion =     Data.Serialize.Get.runGetPartial-      (runSerialT protoVersion $ Data.Serializer.getS logger)+      (runExceptT $ Data.Serializer.getS $ logger protoVersion)    go     :: MonadRemoteStore m

@@ -29,11 +29,11 @@ import System.Nix.Nar (NarSource) import System.Nix.StorePath (HasStoreDir(..), StoreDir) import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, ReplySError, SError)-import System.Nix.Store.Remote.Types.Logger (Logger, BasicError, ErrorInfo)-import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion)+import System.Nix.Store.Remote.Types.Logger (Logger, ErrorInfo)+import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoFeature, ProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..)) -import qualified Data.DList+import Data.DList qualified  data RemoteStoreState = RemoteStoreState {     remoteStoreStateConfig :: ProtoStoreConfig@@ -74,7 +74,7 @@   | RemoteStoreError_SerializerRequest RequestSError   | RemoteStoreError_SerializerReply ReplySError   | RemoteStoreError_IOException SomeException-  | RemoteStoreError_LoggerError (Either BasicError ErrorInfo)+  | 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@@ -85,6 +85,7 @@   | 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

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

@@ -6,8 +6,9 @@   )   where +import Algebra.PartialOrd (leq) import Control.Concurrent.Classy.Async-import Control.Monad (join, void, when)+import Control.Monad (join, unless, void, when) import Control.Monad.Conc.Class (MonadConc) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Trans (lift)@@ -15,26 +16,28 @@ 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.Word (Word32)+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, workerMagic, protoVersion, int, logger, text, trustedFlag)+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(..))-import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..))+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 qualified Data.Some-import qualified Data.Text-import qualified Data.Text.IO-import qualified System.Timeout-import qualified Network.Socket.ByteString+import Data.Some qualified+import Data.Text.IO qualified+import Data.Bits (shiftL)+import Data.ByteString qualified+import Network.Socket.ByteString qualified  type WorkerHelper m   = forall a@@ -124,20 +127,13 @@            special <- case req of             AddToStore {} -> do-              -- This is a hack (but a pretty neat and fast one!)-              -- it should parse nad stream NAR instead               let proxyNarSource :: NarSource IO-                  proxyNarSource f =-                    liftIO-                      (System.Timeout.timeout-                         1000000-                         (Network.Socket.ByteString.recv sock 8)-                      )-                    >>= \case-                      Nothing -> pure ()-                      Just x -> f x >> proxyNarSource f-+                  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 <-@@ -149,21 +145,52 @@            case fst res of             Left e -> throwError e-            Right reply ->-              sockPutS-                (mapErrorS-                   RemoteStoreError_SerializerReply-                   $ getReplyS-                )-                reply+            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+                  (storeRequest storeDir pv)            -- have to be explicit here           -- because otherwise GHC can't conjure Show a, StoreReply a@@ -171,6 +198,7 @@           () <- 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@@ -193,6 +221,7 @@             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@@ -230,42 +259,45 @@        clientVersion <- sockGetS protoVersion -      let leastCommonVersion = min clientVersion serverHandshakeInputOurVersion+      let leastCommonVersion = minVersionNumber clientVersion serverHandshakeInputOurVersion -      when (clientVersion < ProtoVersion 1 10)+      when (not (ProtoVersion 1 37 mempty `leq` clientVersion))         $ throwError         $ RemoteStoreError_WorkerException             WorkerException_ClientVersionTooOld -      when (clientVersion >= ProtoVersion 1 14) $ do-        x :: Word32 <- sockGetS int-        when (x /= 0) $ do-          -- Obsolete CPU affinity.-          _ :: Word32 <- sockGetS int-          pure ()+      -- 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 -      when (clientVersion >= ProtoVersion 1 11) $ do-        _ :: Word32 <- sockGetS int -- obsolete reserveSpace+      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 () -      when (clientVersion >= ProtoVersion 1 33) $ do-        sockPutS-          (mapErrorS-             RemoteStoreError_SerializerPut-             text-          )-          serverHandshakeInputNixVersion+      _ :: Word32 <- sockGetS int -- obsolete reserveSpace -      when (clientVersion >= ProtoVersion 1 35) $ do-        sockPutS-          (mapErrorS-             RemoteStoreError_SerializerHandshake-             trustedFlag-          )-          serverHandshakeInputTrust+      sockPutS+        (mapErrorS RemoteStoreError_SerializerPut text)+        serverHandshakeInputNixVersion +      sockPutS+        (mapErrorS RemoteStoreError_SerializerHandshake trustedFlag)+        serverHandshakeInputTrust+       pure ServerHandshakeOutput-        { serverHandshakeOutputLeastCommonVersion = leastCommonVersion+        { serverHandshakeOutputLeastCommonVersion = leastCommonVersionWithFeatures         , serverHandshakeOutputClientVersion = clientVersion         } @@ -306,7 +338,7 @@   -> Logger   -> m () enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of-  True -> (st, sockPutS logger l)+  True -> (st, do pv <- getProtoVersion; sockPutS (logger pv) l)   False -> (TunnelLoggerState c (l:p), pure ())  _log@@ -323,17 +355,19 @@   => TunnelLogger   -> m () startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,)-  (TunnelLoggerState True []) $-  (traverse_ (sockPutS logger') $ reverse p)-  where logger' = mapErrorS RemoteStoreError_SerializerLogger logger+  (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 [])-  (sockPutS (mapErrorS RemoteStoreError_SerializerLogger logger) Logger_Last)+  (TunnelLoggerState False []) $ do+  pv <- getProtoVersion+  sockPutS (mapErrorS RemoteStoreError_SerializerLogger (logger pv)) Logger_Last  -- | Stop sending logging and report an error. --@@ -351,11 +385,10 @@   case _tunnelLoggerState_canSendStderr st of     False -> (st, pure False)     True -> (,) (TunnelLoggerState False []) $ do-      getProtoVersion >>= \pv -> if protoVersion_minor pv >= 26-        then sockPutS logger' (Logger_Error (Right ex))-        else sockPutS logger' (Logger_Error (Left (BasicError 0 (Data.Text.pack $ show ex))))+      pv <- getProtoVersion+      let logger' = mapErrorS RemoteStoreError_SerializerLogger (logger pv)+      sockPutS logger' (Logger_Error ex)       pure True-  where logger' = mapErrorS RemoteStoreError_SerializerLogger logger  updateLogger   :: MonadRemoteStore m@@ -363,3 +396,46 @@   -> (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

@@ -7,13 +7,12 @@ import Data.Serialize.Put (Put, runPut) import Network.Socket.ByteString (recv, sendAll) import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), RemoteStoreError(..))-import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT)-import System.Nix.Store.Remote.Types (ProtoStoreConfig)+import System.Nix.Store.Remote.Serializer (NixSerializer, runExceptT, runP) -import qualified Control.Exception-import qualified Data.ByteString-import qualified Data.Serializer-import qualified Data.Serialize.Get+import Control.Exception qualified+import Data.ByteString qualified+import Data.Serializer qualified+import Data.Serialize.Get qualified  genericIncremental   :: ( MonadIO m@@ -70,18 +69,13 @@   liftIO $ sendAll soc $ runPut p  sockPutS-  :: ( MonadRemoteStore m-     , MonadError e m-     )-  => NixSerializer ProtoStoreConfig e a+  :: MonadRemoteStore m+  => NixSerializer e a   -> a   -> m () sockPutS s a = do-  cfg <- getConfig   sock <- getStoreSocket-  case runP s cfg a of-    Right x -> liftIO $ sendAll sock x-    Left e -> throwError e+  liftIO $ sendAll sock $ runP s a  sockGetS   :: ( MonadRemoteStore m@@ -89,12 +83,11 @@      , Show a      , Show e      )-  => NixSerializer ProtoStoreConfig e a+  => NixSerializer e a   -> m a sockGetS s = do-  cfg <- getConfig   res <- genericIncremental sockGet8-    $ runSerialT cfg $ Data.Serializer.getS s+    $ runExceptT $ Data.Serializer.getS s    case res of     Right x -> pure x

@@ -13,7 +13,7 @@ -- | Data sent by the client during initial protocol handshake data ClientHandshakeInput = ClientHandshakeInput   { clientHandshakeInputOurVersion :: ProtoVersion -- ^ Our protocol version (that we advertise to the server)-  } deriving (Eq, Generic, Ord, Show)+  } deriving (Eq, Generic, Show)  -- | Data received by the client via initial protocol handshake data ClientHandshakeOutput = ClientHandshakeOutput@@ -21,17 +21,17 @@   , clientHandshakeOutputTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us   , clientHandshakeOutputLeastCommonVersion :: ProtoVersion -- ^ Minimum protocol version supported by both sides   , clientHandshakeOutputServerVersion :: ProtoVersion -- ^ Protocol version supported by the server-  } deriving (Eq, Generic, Ord, Show)+  } 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, Ord, Show)+  } 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, Ord, Show)+  } deriving (Eq, Generic, Show)

@@ -1,7 +1,6 @@ module System.Nix.Store.Remote.Types.Logger   ( Field(..)   , Trace(..)-  , BasicError(..)   , ErrorInfo(..)   , Logger(..)   , LoggerOpCode(..)@@ -29,14 +28,7 @@   }   deriving (Eq, Generic, Ord, Show) -data BasicError = BasicError-  { basicErrorExitStatus :: Int-  , basicErrorMessage :: Text-  }-  deriving (Eq, Generic, Ord, Show)- -- | Extended error info--- available for protoVersion_minor >= 26 data ErrorInfo = ErrorInfo   { errorInfoLevel :: Verbosity   , errorInfoMessage :: Text@@ -84,7 +76,7 @@   | Logger_Read Word64      -- data needed from source   | Logger_Write ByteString -- data for sink   | Logger_Last-  | Logger_Error (Either BasicError ErrorInfo)+  | Logger_Error ErrorInfo   | Logger_StartActivity       { startActivityID :: ActivityID       , startActivityVerbosity :: Verbosity

@@ -1,24 +1,99 @@+{-# 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, Ord, Show)+  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 = 24+    , 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

@@ -24,7 +24,7 @@ data ProtoStoreConfig = ProtoStoreConfig   { protoStoreConfigDir :: StoreDir   , protoStoreConfigProtoVersion :: ProtoVersion-  } deriving (Eq, Generic, Ord, Show)+  } deriving (Eq, Generic, Show)  instance Default ProtoStoreConfig where   def = ProtoStoreConfig def def

@@ -5,14 +5,14 @@ import Data.HashSet (HashSet) import Data.Map (Map) import System.Nix.Build (BuildResult)-import System.Nix.StorePath (StorePath, StorePathName)+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)-import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig)  -- | Get @NixSerializer@ for some type @a@ -- This could also be generalized for every type@@ -20,42 +20,42 @@ -- this for replies and it would make look serializers -- quite hodor, like @a <- getS get; b <- getS get@ class StoreReply a where-  getReplyS :: NixSerializer ProtoStoreConfig ReplySError a+  getReplyS :: StoreDir -> ProtoVersion -> NixSerializer ReplySError a  instance StoreReply SuccessCodeReply where-  getReplyS = opSuccess+  getReplyS _ _ = opSuccess  instance StoreReply NoReply where-  getReplyS = noop NoReply+  getReplyS _ _ = noop NoReply  instance StoreReply Bool where-  getReplyS = mapPrimE bool+  getReplyS _ _ = mapPrimE bool  instance StoreReply BuildResult where-  getReplyS = buildResult+  getReplyS sd pv = buildResult sd pv  instance StoreReply GCResult where-  getReplyS = gcResult+  getReplyS sd _ = gcResult sd  instance StoreReply (Map GCRoot StorePath) where-  getReplyS = mapS gcRoot (mapPrimE storePath)+  getReplyS sd _ = mapS gcRoot (mapPrimE (storePath sd))  instance StoreReply Missing where-  getReplyS = missing+  getReplyS sd _ = missing sd  instance StoreReply (Maybe (Metadata StorePath)) where-  getReplyS = maybePathMetadata+  getReplyS sd _ = maybePathMetadata sd  instance StoreReply StorePath where-  getReplyS = mapPrimE storePath+  getReplyS sd _ = mapPrimE (storePath sd)  instance StoreReply (HashSet StorePath) where-  getReplyS = mapPrimE (hashSet storePath)+  getReplyS sd _ = mapPrimE (hashSet (storePath sd))  instance StoreReply (HashSet StorePathName) where-  getReplyS = mapPrimE (hashSet storePathName)+  getReplyS _ _ = mapPrimE (hashSet storePathName)  mapPrimE-  :: NixSerializer r SError a-  -> NixSerializer r ReplySError a+  :: NixSerializer SError a+  -> NixSerializer ReplySError a mapPrimE = mapErrorS ReplySError_PrimGet

@@ -12,15 +12,16 @@ import Data.Kind (Type) import Data.Map (Map) import Data.Set (Set)-import Data.Text (Text) import Data.Some (Some(Some))  import System.Nix.Build (BuildMode, BuildResult)-import System.Nix.Derivation (Derivation)-import System.Nix.DerivedPath (DerivedPath)+import System.Nix.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 (FileIngestionMethod, RepairMode)+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)@@ -35,9 +36,10 @@   -- | Add @NarSource@ to the store.   AddToStore     :: StorePathName -- ^ Name part of the newly created @StorePath@-    -> FileIngestionMethod -- ^ Add target directory recursively-    -> Some HashAlgo -- ^ Nar hashing algorithm-    -> RepairMode -- ^ Only used by local store backend+    -> ContentAddressMethod -- ^ Content addressing method+    -> Some HashAlgo -- ^ Hashing algorithm+    -> Set StorePath -- ^ References+    -> RepairMode     -> StoreRequest StorePath    -- | Add a NAR with Metadata to the store.@@ -48,6 +50,18 @@     -> 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@@ -84,7 +98,7 @@    BuildDerivation     :: StorePath-    -> Derivation StorePath Text+    -> BasicDerivation     -> BuildMode     -> StoreRequest BuildResult @@ -155,6 +169,17 @@   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 @@ -172,8 +197,9 @@ deriveGShow ''StoreRequest  instance {-# OVERLAPPING #-} Eq (Some StoreRequest) where-  Some (AddToStore a b c d) == Some (AddToStore a' b' c' d') = (a, b, c, d) == (a', b', c', d')+  Some (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'@@ -196,6 +222,7 @@   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') 

@@ -1,13 +1,19 @@-module System.Nix.Store.Remote.Types.WorkerOp +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.+-- 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@@ -56,4 +62,20 @@   | 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

@@ -1,7 +1,7 @@ module Main where -import qualified Test.Hspec-import qualified NixDaemonSpec+import Test.Hspec qualified+import NixDaemonSpec qualified  -- we run remote tests in -- Linux namespaces to avoid interacting with systems store

@@ -22,31 +22,32 @@ 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 qualified Control.Concurrent-import qualified Control.Exception-import qualified Data.ByteString.Char8-import qualified Data.Either-import qualified Data.HashSet-import qualified Data.Map-import qualified Data.Set-import qualified Data.Text-import qualified Data.Text.Encoding-import qualified DataSink-import qualified SampleNar-import qualified System.Directory-import qualified System.Environment-import qualified System.IO.Temp-import qualified System.Linux.Namespaces-import qualified System.Nix.StorePath-import qualified System.Nix.Nar-import qualified System.Posix.User-import qualified System.Process-import qualified Test.Hspec+import Control.Concurrent qualified+import Control.Exception qualified+import Data.ByteString.Char8 qualified+import Data.Either qualified+import Data.HashSet qualified+import Data.Map qualified+import Data.Set qualified+import Data.Text qualified+import Data.Text.Encoding qualified+import DataSink qualified+import SampleNar qualified+import System.Directory qualified+import System.Environment qualified+import System.IO.Temp qualified+import System.Linux.Namespaces qualified+import System.Nix.StorePath qualified+import System.Nix.Nar qualified+import System.Posix.User qualified+import System.Process qualified+import Test.Hspec qualified  createProcessEnv   :: FilePath@@ -290,8 +291,9 @@   addToStore     (forceRight $ System.Nix.StorePath.mkStorePathName "dummy")     (System.Nix.Nar.dumpPath "dummy")-    FileIngestionMethod_Flat+    ContentAddressMethod_NixArchive     (Some HashAlgo_SHA256)+    mempty     RepairMode_DontRepair  invalidPath :: StorePath@@ -457,8 +459,9 @@       addToStore         (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition")         (System.Nix.Nar.dumpPath fp)-        FileIngestionMethod_Flat+        ContentAddressMethod_NixArchive         (Some HashAlgo_SHA256)+        mempty         RepairMode_DontRepair    context "with dummy" $ do

@@ -25,8 +25,8 @@ import Data.STRef import Data.Word -import qualified Data.ByteString-import qualified System.Nix.Nar+import Data.ByteString qualified+import System.Nix.Nar qualified  -- | Sample data for an AddToStoreNar operation data SampleNar

@@ -1,5 +1,6 @@ module Data.SerializerSpec (spec) where +import Control.Monad.Trans.Identity import Data.Some import Data.Serializer import Data.Serializer.Example@@ -10,34 +11,26 @@ spec :: Spec spec = describe "Serializer" $ do   prop "Roundtrips GADT protocol" $ \someCmd ->-    (runG cmdS-     <$> (runP cmdS someCmd))-    `shouldBe`-    ((pure $ pure someCmd) ::-      Either MyPutError-        (Either (GetSerializerError MyGetError)-            (Some Cmd)))--  it "Handles putS error" $-    runP cmdSPutError (Some (Cmd_Bool True))+    (runG cmdS $ runP cmdS someCmd)     `shouldBe`-    Left MyPutError_NoLongerSupported+    (pure someCmd ::+      Either (GetSerializerError MyGetError)+        (Some Cmd))    it "Handles getS error" $-    runG cmdSGetError (runPutSimple cmdS (Some (Cmd_Bool True)))+    runG cmdSGetError (runPutS (cmdS @IdentityT) (Some (Cmd_Bool True)))     `shouldBe`     Left (SerializerError_Get MyGetError_Example)    it "Handles getS fail" $-    runG cmdSGetFail (runPutSimple cmdS (Some (Cmd_Bool True)))+    runG cmdSGetFail (runPutS (cmdS @IdentityT) (Some (Cmd_Bool True)))     `shouldBe`     Left (SerializerError_GetFail @MyGetError "Failed reading: no parse\nEmpty call stack\n")    prop "Roundtrips elaborate example" $ \someCmd readerBool ->-    (runGRest cmdSRest readerBool 0-     <$> (runPRest cmdSRest readerBool 0 someCmd))+    (runGRest (cmdSRest readerBool) readerBool 0+     $ runPRest (cmdSRest readerBool) someCmd)     `shouldBe`-    ((pure $ pure $ someCmd) ::-      Either MyPutError-        (Either (GetSerializerError MyGetError)-            (Some Cmd)))+    (pure someCmd ::+      Either (GetSerializerError MyGetError)+        (Some Cmd))

@@ -4,16 +4,16 @@  import Test.Hspec (SpecWith, Spec, describe, it, shouldBe) -import Data.ByteString (ByteString) import Data.Word (Word64)-import System.Nix.Build (BuildMode(..), BuildStatus(..))-import System.Nix.Store.Remote.Serializer +import System.Nix.Build (BuildMode(..), BuildSuccessStatus(..), BuildFailureStatus(..))+import System.Nix.Store.Remote.Serializer   ( activity   , activityResult   , enum   , int   , loggerOpCode   , runP+  , workerOp   , LoggerSError   , NixSerializer   , SError@@ -34,22 +34,22 @@       -> SpecWith ()     itE name constr value =       it name-        $ ((runP enum () constr) :: Either SError ByteString)+        $ runP @SError enum constr           `shouldBe`-          (runP (int @Word64) () value)+          runP @SError (int @Word64) value      itE'       :: Show a-      => NixSerializer () LoggerSError a+      => NixSerializer LoggerSError a       -> String       -> a       -> Word64       -> SpecWith ()     itE' s name constr value =       it name-        $ ((runP s () constr) :: Either LoggerSError ByteString)+        $ runP s constr           `shouldBe`-          (runP (int @Word64) () (value))+          runP @LoggerSError (int @Word64) value    describe "Enums" $ do     describe "BuildMode enum order matches Nix" $ do@@ -57,23 +57,26 @@       itE "Repair" BuildMode_Repair 1       itE "Check"  BuildMode_Check  2 -    describe "BuildStatus enum order matches Nix" $ do-      itE "Built"                  BuildStatus_Built                   0-      itE "Substituted"            BuildStatus_Substituted             1-      itE "AlreadyValid"           BuildStatus_AlreadyValid            2-      itE "PermanentFailure"       BuildStatus_PermanentFailure        3-      itE "InputRejected"          BuildStatus_InputRejected           4-      itE "OutputRejected"         BuildStatus_OutputRejected          5-      itE "TransientFailure"       BuildStatus_TransientFailure        6-      itE "CachedFailure"          BuildStatus_CachedFailure           7-      itE "TimedOut"               BuildStatus_TimedOut                8-      itE "MiscFailure"            BuildStatus_MiscFailure             9-      itE "DependencyFailed"       BuildStatus_DependencyFailed       10-      itE "LogLimitExceeded"       BuildStatus_LogLimitExceeded       11-      itE "NotDeterministic"       BuildStatus_NotDeterministic       12-      itE "ResolvesToAlreadyValid" BuildStatus_ResolvesToAlreadyValid 13-      itE "NoSubstituters"         BuildStatus_NoSubstituters         14+    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@@ -130,8 +133,15 @@         itE "Vomit"     Verbosity_Vomit     7        describe "WorkerOp enum order matches Nix" $ do-        itE "IsValidPath"           WorkerOp_IsValidPath            1-        itE "BuildPathsWithResults" WorkerOp_BuildPathsWithResults 46+        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   

@@ -3,63 +3,49 @@ module NixSerializerSpec (spec) where  import Crypto.Hash (MD5, SHA1, SHA256, SHA512)-import Data.Some (Some(Some))+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.Derivation (Derivation(inputDrvs))-import System.Nix.Build (BuildResult(..))-import System.Nix.StorePath (StoreDir)+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 (Logger(..))-import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..))-import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..))+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@-roundtripSReader-  :: forall r e a-   . ( Eq a-     , Show a-     , Eq e-     , Show e-     )-  => NixSerializer r e a-  -> r-  -> a-  -> Expectation-roundtripSReader serializer readerVal a =-    (runG serializer readerVal-    <$> runP serializer readerVal a)-    `shouldBe` (pure $ pure a)- roundtripS-  :: ( Eq a+  :: forall e a+   . ( Eq a      , Show a      , Eq e      , Show e      )-  => NixSerializer () e a+  => NixSerializer e a   -> a   -> Expectation-roundtripS serializer = roundtripSReader serializer ()+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 "Int" $ roundtripS @() @Int int     prop "Bool" $ roundtripS bool     prop "ByteString" $ roundtripS byteString     prop "Text" $ roundtripS text     prop "Maybe Text" $ roundtripS maybeText-    prop "UTCTime" $ roundtripS @UTCTime @() time+    prop "UTCTime" $ roundtripS @() @UTCTime time    describe "Combinators" $ do-    prop "list" $ roundtripS @[Int] @() (list int)+    prop "list" $ roundtripS @() @[Int] (list int)     prop "set" $ roundtripS (set byteString)     prop "hashSet" $ roundtripS (hashSet byteString)     prop "mapS" $ roundtripS (mapS (int @Int) byteString)@@ -67,34 +53,21 @@   describe "Complex" $ do     prop "DSum HashAlgo Digest" $ roundtripS namedDigest -    describe "BuildResult" $ do-      prop "< 1.28"-        $ \sd -> forAll (arbitrary `suchThat` ((< 28) . protoVersion_minor))-        $ \pv ->-            roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv)-            . (\x -> x { buildResultBuiltOutputs = Nothing })-            . (\x -> x { buildResultTimesBuilt = Nothing-                       , buildResultIsNonDeterministic = Nothing-                       , buildResultStartTime = Nothing-                       , buildResultStopTime = Nothing-                       }-              )-      prop "= 1.28"-        $ \sd ->-            roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd (ProtoVersion 1 28))-            . (\x -> x { buildResultTimesBuilt = Nothing-                       , buildResultIsNonDeterministic = Nothing-                       , buildResultStartTime = Nothing-                       , buildResultStopTime = Nothing-                       }-              )-      prop "> 1.28"-        $ \sd -> forAll (arbitrary `suchThat` ((> 28) . protoVersion_minor))-        $ \pv ->-            roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv)+    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" $-      roundtripSReader @StoreDir storePath+    prop "StorePath" $ \sd ->+      roundtripS (storePath sd)      prop "StorePathHashPart" $       roundtripS storePathHashPart@@ -102,8 +75,8 @@     prop "StorePathName" $       roundtripS storePathName -    prop "Metadata (StorePath)" $-      roundtripSReader @StoreDir pathMetadata+    prop "Metadata (StorePath)" $ \sd ->+      roundtripS (pathMetadata sd)      prop "Some HashAlgo" $       roundtripS someHashAlgo@@ -114,27 +87,30 @@       prop "SHA256" $ roundtripS . digest @SHA256       prop "SHA512" $ roundtripS . digest @SHA512 -    prop "Derivation" $ \sd ->-      roundtripSReader @StoreDir derivation sd-      . (\drv -> drv { inputDrvs = mempty })+    prop "Derivation" $ \sd drv ->+      roundtripS (basicDerivation sd) $+        System.Nix.Derivation.Traditional.withoutName drv -    prop "ProtoVersion" $ roundtripS @ProtoVersion @() protoVersion+    prop "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 "BasicError" $ roundtripS basicError       prop "ErrorInfo" $ roundtripS errorInfo       prop "LoggerOpCode" $ roundtripS loggerOpCode       prop "Verbosity" $ roundtripS verbosity       prop "Logger"         $ forAll (arbitrary :: Gen ProtoVersion)-        $ \pv ->-            forAll (arbitrary `suchThat` errorInfoIf (protoVersion_minor pv >= 26))-        $ roundtripSReader logger pv+        $ \pv -> roundtripS (logger pv)    describe "Handshake" $ do     prop "WorkerMagic" $ roundtripS workerMagic@@ -145,25 +121,17 @@     prop "StoreText" $ roundtripS storeText      prop "StoreRequest"-      $ \testStoreConfig ->-          forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig)))-          $ roundtripSReader @ProtoStoreConfig storeRequest testStoreConfig+      $ \sd -> forAll arbitrary $ \pv ->+          forAll (arbitrary `suchThat` (restrictProtoVersion pv))+          $ roundtripS (storeRequest sd pv)    describe "StoreReply" $ do     prop "()" $ roundtripS opSuccess-    prop "GCResult" $ roundtripSReader @StoreDir gcResult+    prop "GCResult" $ \sd -> roundtripS (gcResult sd)     prop "GCRoot" $ roundtripS gcRoot-    prop "Missing" $ roundtripSReader @StoreDir missing-    prop "Maybe (Metadata StorePath)" $ roundtripSReader @StoreDir maybePathMetadata+    prop "Missing" $ \sd -> roundtripS (missing sd)+    prop "Maybe (Metadata StorePath)" $ \sd -> roundtripS (maybePathMetadata sd)  restrictProtoVersion :: ProtoVersion -> Some StoreRequest -> Bool-restrictProtoVersion v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False-restrictProtoVersion _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty-restrictProtoVersion v (Some (QueryMissing _)) | v < ProtoVersion 1 30 = False restrictProtoVersion _ _ = True -errorInfoIf :: Bool -> Logger -> Bool-errorInfoIf True  (Logger_Error (Right _)) = True-errorInfoIf False (Logger_Error (Left _))  = True-errorInfoIf _     (Logger_Error _)         = False-errorInfoIf _     _                        = True