Merge pull request #276 from haskell-nix/srk/daemon

Some more server
2024-08-17 22:00:43 +03:00 · 2023-12-12 11:54:28 +01:00 · 2023-12-12 11:54:28 +01:00 · 21040fb589
commit 21040fb589
parent 11da925989 619687b446
21 changed files with 871 additions and 692 deletions
--- a/docs/01-Contributors.org
+++ b/docs/01-Contributors.org
@ -31,3 +31,4 @@ in order of appearance:
 + Ryan Trinkle @ryantrinkle
 + Travis Whitaker @TravisWhitaker
 + Andrea Bedini @andreabedini
+ Dan Bornside @danbornside
--- a/hnix-store-core/src/System/Nix/DerivedPath.hs
+++ b/hnix-store-core/src/System/Nix/DerivedPath.hs
@ -25,12 +25,17 @@ import qualified System.Nix.StorePath

 data OutputsSpec =
    OutputsSpec_All
+  -- ^ Wildcard spec (^*) meaning all outputs
  | OutputsSpec_Names (Set OutputName)
+  -- ^ Set of specific outputs
  deriving (Eq, Generic, Ord, Show)

 data DerivedPath =
    DerivedPath_Opaque StorePath
+  -- ^ Fully evaluated store path that can't be built
+  -- but can be fetched
  | DerivedPath_Built StorePath OutputsSpec
+  -- ^ Derivation path and the outputs built from it
  deriving (Eq, Generic, Ord, Show)

 data ParseOutputsError =
--- a/hnix-store-core/src/System/Nix/Realisation.hs
+++ b/hnix-store-core/src/System/Nix/Realisation.hs
@ -8,6 +8,7 @@ module System.Nix.Realisation (
  , derivationOutputBuilder
  , derivationOutputParser
  , Realisation(..)
+  , RealisationWithId(..)
  ) where

 import Crypto.Hash (Digest)
@ -80,8 +81,7 @@ derivationOutputBuilder outputName DerivationOutput{..} =
 --
 -- realisationId is ommited since it is a key
 -- of type @DerivationOutput OutputName@ so
-- we will use a tuple like @(DerivationOutput OutputName, Realisation)@
-- instead.
+-- we will use @RealisationWithId@ newtype
 data Realisation = Realisation
  { realisationOutPath :: StorePath
  -- ^ Output path
@ -90,3 +90,14 @@ data Realisation = Realisation
  , realisationDependencies :: Map (DerivationOutput OutputName) StorePath
  -- ^ Dependent realisations required for this one to be valid
  } deriving (Eq, Generic, Ord, Show)
+
+-- | For wire protocol
+--
+-- We store this normalized in @Build.buildResultBuiltOutputs@
+-- as @Map (DerivationOutput OutputName) Realisation@
+-- but wire protocol needs it de-normalized so we
+-- need a special (From|To)JSON instances for it
+newtype RealisationWithId = RealisationWithId
+  { unRealisationWithId :: (DerivationOutput OutputName, Realisation)
+  }
+  deriving (Eq, Generic, Ord, Show)
--- a/hnix-store-json/src/System/Nix/JSON.hs
+++ b/hnix-store-json/src/System/Nix/JSON.hs
@ -13,7 +13,7 @@ import Data.Aeson
 import Deriving.Aeson
 import System.Nix.Base (BaseEncoding(NixBase32))
 import System.Nix.OutputName (OutputName)
-import System.Nix.Realisation (DerivationOutput, Realisation)
+import System.Nix.Realisation (DerivationOutput, Realisation, RealisationWithId(..))
 import System.Nix.Signature (Signature)
 import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart)

@ -159,18 +159,18 @@ deriving
  instance FromJSON Realisation

 -- For a keyed version of Realisation
-- we use (DerivationOutput OutputName, Realisation)
+-- we use RealisationWithId (DerivationOutput OutputName, Realisation)
 -- instead of Realisation.id :: (DerivationOutput OutputName)
 -- field.
-instance {-# OVERLAPPING #-} ToJSON (DerivationOutput OutputName, Realisation) where
-  toJSON (drvOut, r) =
+instance ToJSON RealisationWithId where
+  toJSON (RealisationWithId (drvOut, r)) =
    case toJSON r of
      Object o -> Object $ Data.Aeson.KeyMap.insert "id" (toJSON drvOut) o
      _ -> error "absurd"

-instance {-# OVERLAPPING #-} FromJSON (DerivationOutput OutputName, Realisation) where
+instance FromJSON RealisationWithId where
  parseJSON v@(Object o) = do
    r <- parseJSON @Realisation v
    drvOut <- o .: "id"
-    pure (drvOut, r)
+    pure (RealisationWithId (drvOut, r))
  parseJSON x = fail $ "Expected Object but got " ++ show x
--- a/hnix-store-remote/README.md
+++ b/hnix-store-remote/README.md
@ -14,17 +14,14 @@ via `nix-daemon`.
 ```haskell
 {-# LANGUAGE OverloadedStrings #-}

-import Control.Monad (void)
-import Control.Monad.IO.Class (liftIO)
 import System.Nix.StorePath (mkStorePathName)
 import System.Nix.Store.Remote

 main :: IO ()
 main = do
-  void $ runStore $ do
+  runStore $ do
    syncWithGC
    roots <- findRoots
-    liftIO $ print roots

    res <- case mkStorePathName "hnix-store" of
      Left e -> error (show e)
@ -33,5 +30,7 @@ main = do
         (StoreText name "Hello World!")
         mempty
         RepairMode_DontRepair
-    liftIO $ print res
+
+    pure (roots, res)
+  >>= print
 ```
--- a/hnix-store-remote/app/BuildDerivation.hs
+++ b/hnix-store-remote/app/BuildDerivation.hs
@ -2,39 +2,23 @@
 module Main where

 import Data.Default.Class (Default(def))
-import Data.Text (Text)
-import System.Nix.Derivation (Derivation)
-import System.Nix.StorePath (StorePath)

 import qualified Data.Text
-import qualified Data.Text.IO
-import qualified Data.Attoparsec.Text
 import qualified System.Environment
 import qualified System.Nix.Build
-import qualified System.Nix.Derivation
 import qualified System.Nix.StorePath
 import qualified System.Nix.Store.Remote

-parseDerivation :: FilePath -> IO (Derivation StorePath Text)
-parseDerivation source = do
-  contents <- Data.Text.IO.readFile source
-  case Data.Attoparsec.Text.parseOnly
-    (System.Nix.Derivation.parseDerivation def) contents of
-      Left e -> error e
-      Right drv -> pure drv
-
 main :: IO ()
 main = System.Environment.getArgs >>= \case
  [filename] -> do
    case System.Nix.StorePath.parsePathFromText def (Data.Text.pack filename) of
      Left e -> error $ show e
      Right p -> do
-        d <- parseDerivation filename
        out <-
            System.Nix.Store.Remote.runStore
          $ System.Nix.Store.Remote.buildDerivation
              p
-              d
              System.Nix.Build.BuildMode_Normal
        print out
  _ -> error "No input derivation file"
--- a/hnix-store-remote/hnix-store-remote.cabal
+++ b/hnix-store-remote/hnix-store-remote.cabal
@ -46,11 +46,6 @@ common commons
    , ViewPatterns
  default-language: Haskell2010

-common tests
-  import: commons
-  build-tool-depends:
-      tasty-discover:tasty-discover
-
 flag io-testsuite
  default:
    False
@ -119,7 +114,9 @@ library
    , data-default-class
    , dependent-sum > 0.7
    , dependent-sum-template >= 0.2.0.1 && < 0.3
+--    , directory
    , dlist >= 1.0
+    , exceptions
    , generic-arbitrary < 1.1
    , hashable
    , text
@ -139,7 +136,6 @@ executable build-derivation
    buildable: False
  build-depends:
      base >=4.12 && <5
-    , attoparsec
    , hnix-store-core
    , hnix-store-remote
    , data-default-class
@ -163,7 +159,7 @@ executable remote-readme
  ghc-options: -pgmL markdown-unlit -Wall

 test-suite remote
-  import: tests
+  import: commons
  type:              exitcode-stdio-1.0
  main-is:           Driver.hs
  hs-source-dirs:    tests
@ -187,7 +183,7 @@ test-suite remote
    , QuickCheck

 test-suite remote-io
-  import: tests
+  import: commons

  if !flag(io-testsuite) || os(darwin)
    buildable: False
@ -206,9 +202,11 @@ test-suite remote-io
    , hnix-store-remote
    , hnix-store-tests
    , bytestring
+    , concurrency
    , containers
    , crypton
    , directory
+    , exceptions
    , filepath
    , hspec
    , hspec-expectations-lifted
--- a/hnix-store-remote/src/System/Nix/Store/Remote.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs
@ -1,6 +1,8 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+
 module System.Nix.Store.Remote
-  (
-    module System.Nix.Store.Types
+  ( module System.Nix.Store.Types
  , module System.Nix.Store.Remote.Client
  , module System.Nix.Store.Remote.MonadStore
  , module System.Nix.Store.Remote.Types
@ -8,79 +10,190 @@ module System.Nix.Store.Remote
  , MonadStore
  -- * Runners
  , runStore
-  , runStoreOpts
-  , runStoreOptsTCP
+  , runStoreConnection
+  , runStoreSocket
+  -- ** Daemon
+  , runDaemon
+  , runDaemonConnection
+  , justdoit
  ) where

+import Control.Monad.Catch (MonadMask)
+import Control.Monad.Conc.Class (MonadConc)
+import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Default.Class (Default(def))
 import Network.Socket (Family, SockAddr(SockAddrUnix))
 import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
-import System.Nix.StorePath (StoreDir)
-import System.Nix.Store.Remote.MonadStore (RemoteStoreT, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed))
+import System.Nix.Store.Remote.MonadStore
+  ( runRemoteStoreT
+  , MonadRemoteStore(..)
+  , RemoteStoreT
+  , RemoteStoreError(RemoteStoreError_GetAddrInfoFailed))
 import System.Nix.Store.Remote.Client
+import System.Nix.Store.Remote.Server (WorkerHelper, runProxyDaemon)
 import System.Nix.Store.Remote.Types

-import qualified Control.Exception
+import qualified Control.Monad.Catch
 import qualified Network.Socket
+-- see TODO bellow
+--import qualified System.Directory
+
+-- wip justdoit
+import System.Nix.StorePath (StorePath)
+import qualified System.Nix.StorePath

 -- * Compat

-type MonadStore = RemoteStoreT StoreConfig IO
+type MonadStore = RemoteStoreT IO

 -- * Runners

-runStore :: MonadStore a -> Run IO a
-runStore = runStoreOpts defaultSockPath def
-  where
-    defaultSockPath :: String
-    defaultSockPath = "/nix/var/nix/daemon-socket/socket"
+runStore
+  :: ( MonadIO m
+     , MonadMask m
+     )
+  => RemoteStoreT m a
+  -> Run m a
+runStore = runStoreConnection def

-runStoreOpts
-  :: FilePath
-  -> StoreDir
-  -> MonadStore a
-  -> Run IO a
-runStoreOpts socketPath =
-  runStoreOpts'
-    Network.Socket.AF_UNIX
-    (SockAddrUnix socketPath)
+runStoreConnection
+  :: ( MonadIO m
+     , MonadMask m
+     )
+  => StoreConnection
+  -> RemoteStoreT m a
+  -> Run m a
+runStoreConnection sc k =
+  connectionToSocket sc
+  >>= \case
+    Left e -> pure (Left e, mempty)
+    Right (fam, sock) -> runStoreSocket fam sock k

-runStoreOptsTCP
-  :: String
-  -> Int
-  -> StoreDir
-  -> MonadStore a
-  -> Run IO a
-runStoreOptsTCP host port sd code = do
-  Network.Socket.getAddrInfo
-    (Just Network.Socket.defaultHints)
-    (Just host)
-    (Just $ show port)
-    >>= \case
-      (sockAddr:_) ->
-        runStoreOpts'
-          (Network.Socket.addrFamily sockAddr)
-          (Network.Socket.addrAddress sockAddr)
-          sd
-          code
-      _ -> pure (Left RemoteStoreError_GetAddrInfoFailed, mempty)
-
-runStoreOpts'
-  :: Family
+runStoreSocket
+  :: ( MonadIO m
+     , MonadMask m
+     )
+  => Family
  -> SockAddr
-  -> StoreDir
-  -> MonadStore a
-  -> Run IO a
-runStoreOpts' sockFamily sockAddr storeRootDir code =
-  Control.Exception.bracket
-    open
-    (Network.Socket.close . hasStoreSocket)
-    (flip runStoreSocket code)
+  -> RemoteStoreT m a
+  -> Run m a
+runStoreSocket sockFamily sockAddr code =
+  Control.Monad.Catch.bracket
+    (liftIO open)
+    (liftIO . Network.Socket.close . hasStoreSocket)
+    (\s -> runRemoteStoreT s $ greetServer >> code)
  where
    open = do
-      soc <- Network.Socket.socket sockFamily Network.Socket.Stream 0
+      soc <-
+        Network.Socket.socket
+          sockFamily
+          Network.Socket.Stream
+          Network.Socket.defaultProtocol
      Network.Socket.connect soc sockAddr
-      pure PreStoreConfig
-          { preStoreConfig_socket = soc
-          , preStoreConfig_dir = storeRootDir
-          }
+      pure soc
+
+justdoit :: Run IO (Bool, Bool)
+justdoit = do
+  runDaemonConnection runStore (pure ()) (StoreConnection_Socket "/tmp/dsock") $
+    runStoreConnection (StoreConnection_Socket "/tmp/dsock")
+      $ do
+        a <- isValidPath pth
+        b <- isValidPath pth
+        pure (a, b)
+  where
+    pth :: StorePath
+    pth =
+      either (error . show) id
+      $ System.Nix.StorePath.parsePathFromText
+        def
+        "/nix/store/yyznqbwam67cmp7zfwk0rkgmi9yqsdsm-hnix-store-core-0.8.0.0"
+
+runDaemon
+  :: forall m a
+  . ( MonadIO m
+    , MonadConc m
+    )
+  => WorkerHelper m
+  -> m a
+  -> m a
+runDaemon workerHelper =
+  runDaemonConnection
+    workerHelper
+    (pure ())
+    def
+
+-- | Run an emulated nix daemon using given @StoreConnection@
+-- the deamon will close when the continuation returns.
+runDaemonConnection
+  :: forall m a
+  . ( MonadIO m
+    , MonadConc m
+    )
+  => WorkerHelper m
+  -> RemoteStoreT m ()
+  -> StoreConnection
+  -> m a
+  -> m a
+runDaemonConnection workerHelper postGreet sc k =
+  connectionToSocket sc
+  >>= \case
+    Left e -> error $ show e
+    Right (fam, sock) -> runDaemonSocket workerHelper postGreet fam sock k
+
+-- | Run an emulated nix daemon using given @StoreConnection@
+-- the deamon will close when the continuation returns.
+runDaemonSocket
+  :: forall m a
+  . ( MonadIO m
+    , MonadConc m
+    )
+  => WorkerHelper m
+  -> RemoteStoreT m ()
+  -> Family
+  -> SockAddr
+  -> m a
+  -> m a
+runDaemonSocket workerHelper postGreet sockFamily sockAddr k =
+  Control.Monad.Catch.bracket
+    (liftIO
+      $ Network.Socket.socket
+          sockFamily
+          Network.Socket.Stream
+          Network.Socket.defaultProtocol
+    )
+    (\lsock -> liftIO $ Network.Socket.close lsock)
+    $ \lsock -> do
+    -- TODO: the: (\lsock -> liftIO $ Network.Socket.close lsock *> System.Directory.removeFile f)
+    -- branch should really be (and even removeFile is currently omitted)
+    -- a file lock followed by unlink *before* bind rather than after close.  If
+    -- the program crashes (or loses power or something) then a stale unix
+    -- socket will stick around and prevent the daemon from starting.  using a
+    -- lock file instead means only one "copy" of the daemon can hold the lock,
+    -- and can safely unlink the socket before binding no matter how shutdown
+    -- occured.
+
+    -- set up the listening socket
+    liftIO $ Network.Socket.bind lsock sockAddr
+    runProxyDaemon workerHelper postGreet lsock k
+
+connectionToSocket
+  :: MonadIO m
+  => StoreConnection
+  -> m (Either RemoteStoreError (Family, SockAddr))
+connectionToSocket (StoreConnection_Socket (StoreSocketPath f)) =
+  pure $ pure
+    ( Network.Socket.AF_UNIX
+    , SockAddrUnix f
+    )
+connectionToSocket (StoreConnection_TCP StoreTCP{..}) = do
+  addrInfo <- liftIO $ Network.Socket.getAddrInfo
+    (Just Network.Socket.defaultHints)
+    (Just storeTCPHost)
+    (Just $ show storeTCPPort)
+  case addrInfo of
+      (sockAddr:_) ->
+        pure $ pure
+          ( Network.Socket.addrFamily sockAddr
+          , Network.Socket.addrAddress sockAddr
+          )
+      _ -> pure (Left RemoteStoreError_GetAddrInfoFailed)
--- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs
@ -17,8 +17,8 @@ deriving via GenericArbitrary CheckMode
 deriving via GenericArbitrary SubstituteMode
  instance Arbitrary SubstituteMode

-deriving via GenericArbitrary TestStoreConfig
-  instance Arbitrary TestStoreConfig
+deriving via GenericArbitrary ProtoStoreConfig
+  instance Arbitrary ProtoStoreConfig

 deriving via GenericArbitrary ProtoVersion
  instance Arbitrary ProtoVersion
--- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs
@ -32,10 +32,8 @@ import Data.HashSet (HashSet)
 import Data.Map (Map)
 import Data.Set (Set)
 import Data.Some (Some)
-import Data.Text (Text)

 import System.Nix.Build (BuildMode, BuildResult)
-import System.Nix.Derivation (Derivation)
 import System.Nix.DerivedPath (DerivedPath)
 import System.Nix.Hash (HashAlgo(..))
 import System.Nix.Nar (NarSource)
@ -52,6 +50,12 @@ import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode)
 import System.Nix.Store.Remote.Client.Core
 import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))

+import qualified Control.Monad.IO.Class
+import qualified Data.Attoparsec.Text
+import qualified Data.Text.IO
+import qualified System.Nix.Derivation
+import qualified System.Nix.StorePath
+
 -- | Add `NarSource` to the store
 addToStore
  :: MonadRemoteStore m
@ -114,10 +118,18 @@ addIndirectRoot = doReq . AddIndirectRoot
 buildDerivation
  :: MonadRemoteStore m
  => StorePath
-  -> Derivation StorePath Text
  -> BuildMode
  -> m BuildResult
-buildDerivation a b c = doReq (BuildDerivation a b c)
+buildDerivation sp mode = do
+  sd <- getStoreDir
+  drvContents <-
+    Control.Monad.IO.Class.liftIO
+    $ Data.Text.IO.readFile
+    $ System.Nix.StorePath.storePathToFilePath sd sp
+  case Data.Attoparsec.Text.parseOnly
+    (System.Nix.Derivation.parseDerivation sd) drvContents of
+      Left e -> throwError $ RemoteStoreError_DerivationParse e
+      Right drv -> doReq (BuildDerivation sp drv mode)

 -- | Build paths if they are an actual derivations.
 --
--- a/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs
@ -1,6 +1,6 @@
 module System.Nix.Store.Remote.Client.Core
  ( Run
-  , runStoreSocket
+  , greetServer
  , doReq
  ) where

@ -12,13 +12,8 @@ import Data.Some (Some(Some))
 import System.Nix.Nar (NarSource)
 import System.Nix.Store.Remote.Logger (processOutput)
 import System.Nix.Store.Remote.MonadStore
-  ( MonadRemoteStore
+  ( MonadRemoteStore(..)
  , RemoteStoreError(..)
-  , RemoteStoreT
-  , runRemoteStoreT
-  , mapStoreConfig
-  , takeNarSource
-  , getStoreSocket
  )
 import System.Nix.Store.Remote.Socket (sockPutS, sockGetS)
 import System.Nix.Store.Remote.Serializer
@ -31,10 +26,9 @@ import System.Nix.Store.Remote.Serializer
  , trustedFlag
  , workerMagic
  )
-import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeInput(..), ClientHandshakeOutput(..))
+import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeOutput(..))
 import System.Nix.Store.Remote.Types.Logger (Logger)
-import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion)
-import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig)
+import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..))
 import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))
 import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..))
 import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
@ -84,91 +78,68 @@ doReq = \case
        $ getReplyS @a
      )

-runStoreSocket
-  :: ( Monad m
-     , MonadIO m
-     )
-  => PreStoreConfig
-  -> RemoteStoreT StoreConfig m a
-  -> Run m a
-runStoreSocket preStoreConfig code =
-  runRemoteStoreT preStoreConfig $ do
-    ClientHandshakeOutput{..}
-      <- greet
-          ClientHandshakeInput
-          { clientHandshakeInputOurVersion = ourProtoVersion
-          }
+greetServer
+  :: MonadRemoteStore m
+  => m ClientHandshakeOutput
+greetServer = do
+  sockPutS
+    (mapErrorS
+      RemoteStoreError_SerializerHandshake
+      workerMagic
+    )
+    WorkerMagic_One

-    mapStoreConfig
-      (preStoreConfigToStoreConfig
-        clientHandshakeOutputLeastCommonVerison)
-      code
+  magic <-
+    sockGetS
+    $ mapErrorS
+        RemoteStoreError_SerializerHandshake
+        workerMagic

-  where
-    greet
-      :: MonadIO m
-      => ClientHandshakeInput
-      -> RemoteStoreT PreStoreConfig m ClientHandshakeOutput
-    greet ClientHandshakeInput{..} = do
+  unless
+    (magic == WorkerMagic_Two)
+    $ throwError RemoteStoreError_WorkerMagic2Mismatch

-      sockPutS
-        (mapErrorS
-          RemoteStoreError_SerializerHandshake
-          workerMagic
-        )
-        WorkerMagic_One
+  daemonVersion <- sockGetS protoVersion

-      magic <-
+  when (daemonVersion < ProtoVersion 1 10)
+    $ throwError RemoteStoreError_ClientVersionTooOld
+
+  pv <- getProtoVersion
+  sockPutS protoVersion pv
+
+  let leastCommonVersion = min daemonVersion pv
+
+  when (leastCommonVersion >= ProtoVersion 1 14)
+    $ sockPutS int (0 :: Int) -- affinity, obsolete
+
+  when (leastCommonVersion >= ProtoVersion 1 11) $ do
+    sockPutS
+      (mapErrorS RemoteStoreError_SerializerPut bool)
+      False -- reserveSpace, obsolete
+
+  daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33
+    then do
+      -- If we were buffering I/O, we would flush the output here.
+      txtVer <-
        sockGetS
-        $ mapErrorS
-            RemoteStoreError_SerializerHandshake
-            workerMagic
+          $ mapErrorS
+              RemoteStoreError_SerializerGet
+              text
+      pure $ Just txtVer
+    else pure Nothing

-      unless
-        (magic == WorkerMagic_Two)
-        $ throwError RemoteStoreError_WorkerMagic2Mismatch
+  remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35
+    then do
+      sockGetS
+        $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag
+    else pure Nothing

-      daemonVersion <- sockGetS protoVersion
+  setProtoVersion leastCommonVersion
+  processOutput

-      when (daemonVersion < ProtoVersion 1 10)
-        $ throwError RemoteStoreError_ClientVersionTooOld
-
-      sockPutS protoVersion clientHandshakeInputOurVersion
-
-      let leastCommonVersion = min daemonVersion ourProtoVersion
-
-      when (leastCommonVersion >= ProtoVersion 1 14)
-        $ sockPutS int (0 :: Int) -- affinity, obsolete
-
-      when (leastCommonVersion >= ProtoVersion 1 11) $ do
-        sockPutS
-          (mapErrorS RemoteStoreError_SerializerPut bool)
-          False -- reserveSpace, obsolete
-
-      daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33
-        then do
-          -- If we were buffering I/O, we would flush the output here.
-          txtVer <-
-            sockGetS
-              $ mapErrorS
-                  RemoteStoreError_SerializerGet
-                  text
-          pure $ Just txtVer
-        else pure Nothing
-
-      remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35
-        then do
-          sockGetS
-            $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag
-        else pure Nothing
-
-      mapStoreConfig
-        (preStoreConfigToStoreConfig leastCommonVersion)
-        processOutput
-
-      pure ClientHandshakeOutput
-        { clientHandshakeOutputNixVersion = daemonNixVersion
-        , clientHandshakeOutputTrust = remoteTrustsUs
-        , clientHandshakeOutputLeastCommonVerison = leastCommonVersion
-        , clientHandshakeOutputServerVersion = daemonVersion
-        }
+  pure ClientHandshakeOutput
+    { clientHandshakeOutputNixVersion = daemonNixVersion
+    , clientHandshakeOutputTrust = remoteTrustsUs
+    , clientHandshakeOutputLeastCommonVersion = leastCommonVersion
+    , clientHandshakeOutputServerVersion = daemonVersion
+    }
--- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs
@ -8,22 +8,21 @@ module System.Nix.Store.Remote.MonadStore
  , WorkerException(..)
  , RemoteStoreT
  , runRemoteStoreT
-  , mapStoreConfig
-  , MonadRemoteStoreR(..)
-  , MonadRemoteStore
-  , getProtoVersion
+  , MonadRemoteStore(..)
  ) where

 import Control.Exception (SomeException)
+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
 import Control.Monad.Except (MonadError)
 import Control.Monad.IO.Class (MonadIO)
-import Control.Monad.Reader (MonadReader, ask, asks)
-import Control.Monad.State.Strict (get, modify)
+import Control.Monad.Reader (MonadReader, ask)
+import Control.Monad.State.Strict (get, gets, modify)
 import Control.Monad.Trans (MonadTrans, lift)
-import Control.Monad.Trans.State.Strict (StateT, runStateT, mapStateT)
-import Control.Monad.Trans.Except (ExceptT, runExceptT, mapExceptT)
-import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT)
+import Control.Monad.Trans.State.Strict (StateT, runStateT)
+import Control.Monad.Trans.Except (ExceptT, runExceptT)
+import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import Data.ByteString (ByteString)
+import Data.Default.Class (Default(def))
 import Data.DList (DList)
 import Data.Word (Word64)
 import Network.Socket (Socket)
@ -32,29 +31,36 @@ import System.Nix.StorePath (HasStoreDir(..), StoreDir)
 import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, ReplySError, SError)
 import System.Nix.Store.Remote.Types.Logger (Logger, BasicError, ErrorInfo)
 import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion)
-import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig)
+import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..))

 import qualified Data.DList

 data RemoteStoreState = RemoteStoreState {
-    remoteStoreState_logs :: DList Logger
-  , remoteStoreState_gotError :: Bool
-  , remoteStoreState_mDataSource :: Maybe (Word64 -> IO (Maybe ByteString))
+    remoteStoreStateConfig :: ProtoStoreConfig
+  , remoteStoreStateLogs :: DList Logger
+  , remoteStoreStateMDataSource :: Maybe (Word64 -> IO (Maybe ByteString))
  -- ^ Source for @Logger_Read@, this will be called repeatedly
  -- as the daemon requests chunks of size @Word64@.
  -- If the function returns Nothing and daemon tries to read more
  -- data an error is thrown.
  -- Used by @AddToStoreNar@ and @ImportPaths@ operations.
-  , remoteStoreState_mDataSink :: Maybe (ByteString -> IO ())
+  , remoteStoreStateMDataSink :: Maybe (ByteString -> IO ())
  -- ^ Sink for @Logger_Write@, called repeatedly by the daemon
  -- to dump us some data. Used by @ExportPath@ operation.
-  , remoteStoreState_mNarSource :: Maybe (NarSource IO)
+  , remoteStoreStateMNarSource :: Maybe (NarSource IO)
  }

+instance HasStoreDir RemoteStoreState where
+  hasStoreDir = hasStoreDir . remoteStoreStateConfig
+
+instance HasProtoVersion RemoteStoreState where
+  hasProtoVersion = hasProtoVersion . remoteStoreStateConfig
+
 data RemoteStoreError
  = RemoteStoreError_Fixme String
  | RemoteStoreError_BuildFailed
  | RemoteStoreError_ClientVersionTooOld
+  | RemoteStoreError_DerivationParse String
  | RemoteStoreError_Disconnected
  | RemoteStoreError_GetAddrInfoFailed
  | RemoteStoreError_GenericIncrementalLeftovers String ByteString -- when there are bytes left over after genericIncremental parser is done, (Done x leftover), first param is show x
@ -69,9 +75,9 @@ data RemoteStoreError
  | RemoteStoreError_LoggerError (Either BasicError ErrorInfo)
  | RemoteStoreError_LoggerLeftovers String ByteString -- when there are bytes left over after incremental logger parser is done, (Done x leftover), first param is show x
  | RemoteStoreError_LoggerParserFail String ByteString -- when incremental parser returns ((Fail msg leftover) :: Result)
-  | RemoteStoreError_NoDataSourceProvided -- remoteStoreState_mDataSource is required but it is Nothing
-  | RemoteStoreError_DataSourceExhausted -- remoteStoreState_mDataSource returned Nothing but more data was requested
-  | RemoteStoreError_NoDataSinkProvided -- remoteStoreState_mDataSink is required but it is Nothing
+  | RemoteStoreError_NoDataSourceProvided -- remoteStoreStateMDataSource is required but it is Nothing
+  | RemoteStoreError_DataSourceExhausted -- remoteStoreStateMDataSource returned Nothing but more data was requested
+  | RemoteStoreError_NoDataSinkProvided -- remoteStoreStateMDataSink is required but it is Nothing
  | RemoteStoreError_NoNarSourceProvided
  | RemoteStoreError_OperationFailed
  | RemoteStoreError_ProtocolMismatch
@ -100,91 +106,116 @@ data WorkerError
  | WorkerError_UnsupportedOperation
  deriving (Eq, Ord, Show)

-newtype RemoteStoreT r m a = RemoteStoreT
+newtype RemoteStoreT m a = RemoteStoreT
  { _unRemoteStoreT
      :: ExceptT RemoteStoreError
          (StateT RemoteStoreState
-            (ReaderT r m)) a
+            (ReaderT Socket m)) a
  }
  deriving
    ( Functor
    , Applicative
    , Monad
-    , MonadReader r
+    , MonadReader Socket
    --, MonadState StoreState -- Avoid making the internal state explicit
    , MonadError RemoteStoreError
+    , MonadCatch
+    , MonadMask
+    , MonadThrow
    , MonadIO
    )

-instance MonadTrans (RemoteStoreT r) where
+instance MonadTrans RemoteStoreT where
  lift = RemoteStoreT . lift . lift . lift

 -- | Runner for @RemoteStoreT@
 runRemoteStoreT
-  :: ( HasStoreDir r
-     , HasStoreSocket r
-     , Monad m
-     )
-  => r
-  -> RemoteStoreT r m a
+  :: Monad m
+  => Socket
+  -> RemoteStoreT m a
  -> m (Either RemoteStoreError a, DList Logger)
-runRemoteStoreT r =
-    fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreState_logs))
-  . (`runReaderT` r)
+runRemoteStoreT sock =
+    fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreStateLogs))
+  . (`runReaderT` sock)
  . (`runStateT` emptyState)
  . runExceptT
  . _unRemoteStoreT
  where
    emptyState = RemoteStoreState
-      { remoteStoreState_logs = mempty
-      , remoteStoreState_gotError = False
-      , remoteStoreState_mDataSource = Nothing
-      , remoteStoreState_mDataSink = Nothing
-      , remoteStoreState_mNarSource = Nothing
+      { remoteStoreStateConfig = def
+      , remoteStoreStateLogs = mempty
+      , remoteStoreStateMDataSource = Nothing
+      , remoteStoreStateMDataSink = Nothing
+      , remoteStoreStateMNarSource = Nothing
      }

-mapStoreConfig
-  :: (rb -> ra)
-  -> (RemoteStoreT ra m a -> RemoteStoreT rb m a)
-mapStoreConfig f =
-  RemoteStoreT
-  . ( mapExceptT
-    . mapStateT
-    . withReaderT
-    ) f
-  . _unRemoteStoreT
-
 class ( MonadIO m
      , MonadError RemoteStoreError m
-      , HasStoreSocket r
-      , HasStoreDir r
-      , MonadReader r m
      )
-      => MonadRemoteStoreR r m where
+      => MonadRemoteStore m where

  appendLog :: Logger -> m ()
  default appendLog
    :: ( MonadTrans t
-       , MonadRemoteStoreR r m'
+       , MonadRemoteStore m'
       , m ~ t m'
       )
    => Logger
    -> m ()
  appendLog = lift . appendLog

+  getConfig :: m ProtoStoreConfig
+  default getConfig
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => m ProtoStoreConfig
+  getConfig = lift getConfig
+
  getStoreDir :: m StoreDir
  default getStoreDir
    :: ( MonadTrans t
-       , MonadRemoteStoreR r m'
+       , MonadRemoteStore m'
       , m ~ t m'
       )
    => m StoreDir
  getStoreDir = lift getStoreDir

+  setStoreDir :: StoreDir -> m ()
+  default setStoreDir
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => StoreDir
+    -> m ()
+  setStoreDir = lift . setStoreDir
+
+  -- | Get @ProtoVersion@ from state
+  getProtoVersion :: m ProtoVersion
+  default getProtoVersion
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => m ProtoVersion
+  getProtoVersion = lift getProtoVersion
+
+  setProtoVersion :: ProtoVersion -> m ()
+  default setProtoVersion
+    :: ( MonadTrans t
+       , MonadRemoteStore m'
+       , m ~ t m'
+       )
+    => ProtoVersion
+    -> m ()
+  setProtoVersion = lift . setProtoVersion
+
  getStoreSocket :: m Socket
  default getStoreSocket
    :: ( MonadTrans t
-       , MonadRemoteStoreR r m'
+       , MonadRemoteStore m'
       , m ~ t m'
       )
    => m Socket
@ -193,7 +224,7 @@ class ( MonadIO m
  setNarSource :: NarSource IO -> m ()
  default setNarSource
   :: ( MonadTrans t
-      , MonadRemoteStoreR r m'
+      , MonadRemoteStore m'
      , m ~ t m'
      )
   => NarSource IO
@ -203,7 +234,7 @@ class ( MonadIO m
  takeNarSource :: m (Maybe (NarSource IO))
  default takeNarSource
   :: ( MonadTrans t
-      , MonadRemoteStoreR r m'
+      , MonadRemoteStore m'
      , m ~ t m'
      )
   => m (Maybe (NarSource IO))
@ -212,7 +243,7 @@ class ( MonadIO m
  setDataSource :: (Word64 -> IO (Maybe ByteString)) -> m ()
  default setDataSource
   :: ( MonadTrans t
-      , MonadRemoteStoreR r m'
+      , MonadRemoteStore m'
      , m ~ t m'
      )
   => (Word64 -> IO (Maybe ByteString))
@ -222,7 +253,7 @@ class ( MonadIO m
  getDataSource :: m (Maybe (Word64 -> IO (Maybe ByteString)))
  default getDataSource
   :: ( MonadTrans t
-      , MonadRemoteStoreR r m'
+      , MonadRemoteStore m'
      , m ~ t m'
      )
   => m (Maybe (Word64 -> IO (Maybe ByteString)))
@ -231,7 +262,7 @@ class ( MonadIO m
  clearDataSource :: m ()
  default clearDataSource
    :: ( MonadTrans t
-       , MonadRemoteStoreR r m'
+       , MonadRemoteStore m'
       , m ~ t m'
       )
    => m ()
@ -240,7 +271,7 @@ class ( MonadIO m
  setDataSink :: (ByteString -> IO ()) -> m ()
  default setDataSink
   :: ( MonadTrans t
-      , MonadRemoteStoreR r m'
+      , MonadRemoteStore m'
      , m ~ t m'
      )
   => (ByteString -> IO ())
@ -250,7 +281,7 @@ class ( MonadIO m
  getDataSink :: m (Maybe (ByteString -> IO ()))
  default getDataSink
   :: ( MonadTrans t
-      , MonadRemoteStoreR r m'
+      , MonadRemoteStore m'
      , m ~ t m'
      )
   => m (Maybe (ByteString -> IO ()))
@ -259,50 +290,49 @@ class ( MonadIO m
  clearDataSink :: m ()
  default clearDataSink
    :: ( MonadTrans t
-       , MonadRemoteStoreR r m'
+       , MonadRemoteStore m'
       , m ~ t m'
       )
    => m ()
  clearDataSink = lift clearDataSink

-instance MonadRemoteStoreR r m => MonadRemoteStoreR r (StateT s m)
-instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ReaderT r m)
-instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ExceptT RemoteStoreError m)
+instance MonadRemoteStore m => MonadRemoteStore (StateT s m)
+instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m)
+instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m)

-type MonadRemoteStore m = MonadRemoteStoreR StoreConfig m
+instance MonadIO m => MonadRemoteStore (RemoteStoreT m) where

-instance ( MonadIO m
-         , HasStoreDir r
-         , HasStoreSocket r
-         )
-         => MonadRemoteStoreR r (RemoteStoreT r m) where
+  getConfig = RemoteStoreT $ gets remoteStoreStateConfig
+  getProtoVersion = RemoteStoreT $ gets hasProtoVersion
+  setProtoVersion pv =
+    RemoteStoreT $ modify $ \s ->
+      s { remoteStoreStateConfig =
+            (remoteStoreStateConfig s) { protoStoreConfigProtoVersion = pv }
+      }
+  getStoreDir = RemoteStoreT $ gets hasStoreDir
+  setStoreDir sd =
+    RemoteStoreT $ modify $ \s ->
+      s { remoteStoreStateConfig =
+            (remoteStoreStateConfig s) { protoStoreConfigDir = sd }
+      }

-  getStoreDir = hasStoreDir <$> RemoteStoreT ask
-  getStoreSocket = hasStoreSocket <$> RemoteStoreT ask
+  getStoreSocket = RemoteStoreT ask

  appendLog x =
    RemoteStoreT
    $ modify
-    $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s `Data.DList.snoc` x }
+    $ \s -> s { remoteStoreStateLogs = remoteStoreStateLogs s `Data.DList.snoc` x }

-  setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = pure x }
-  getDataSource = remoteStoreState_mDataSource <$> RemoteStoreT get
-  clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = Nothing }
+  setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = pure x }
+  getDataSource = RemoteStoreT (gets remoteStoreStateMDataSource)
+  clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = Nothing }

-  setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = pure x }
-  getDataSink = remoteStoreState_mDataSink <$> RemoteStoreT get
-  clearDataSink = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = Nothing }
+  setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSink = pure x }
+  getDataSink = RemoteStoreT (gets remoteStoreStateMDataSink)
+  clearDataSink = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSink = Nothing }

-  setNarSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mNarSource = pure x }
+  setNarSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMNarSource = pure x }
  takeNarSource = RemoteStoreT $ do
-    x <- remoteStoreState_mNarSource <$> get
-    modify $ \s -> s { remoteStoreState_mNarSource = Nothing }
+    x <- remoteStoreStateMNarSource <$> get
+    modify $ \s -> s { remoteStoreStateMNarSource = Nothing }
    pure x
-
-- | Ask for a @StoreDir@
-getProtoVersion
-  :: ( MonadRemoteStoreR r m
-     , HasProtoVersion r
-     )
-  => m ProtoVersion
-getProtoVersion = asks hasProtoVersion
--- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs
@ -131,7 +131,7 @@ 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(..))
+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)
@ -1398,7 +1398,7 @@ derivationOutputTyped = mapErrorS ReplySError_DerivationOutput $
 realisation :: NixSerializer r ReplySError Realisation
 realisation = mapErrorS ReplySError_Realisation json

-realisationWithId :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName, Realisation)
+realisationWithId :: NixSerializer r ReplySError RealisationWithId
 realisationWithId = mapErrorS ReplySError_RealisationWithId json

 -- *** BuildResult
@ -1434,7 +1434,7 @@ buildResult = Serializer
        then
            pure
          . Data.Map.Strict.fromList
-          . map (\(_, (a, b)) -> (a, b))
+          . map (\(_, RealisationWithId (a, b)) -> (a, b))
          . Data.Map.Strict.toList
          <$> getS (mapS derivationOutputTyped realisationWithId)
        else pure Nothing
@ -1453,7 +1453,7 @@ buildResult = Serializer
      Control.Monad.when (protoVersion_minor pv >= 28)
        $ putS (mapS derivationOutputTyped realisationWithId)
        $ Data.Map.Strict.fromList
-        $ map (\(a, b) -> (a, (a, b)))
+        $ map (\(a, b) -> (a, RealisationWithId (a, b)))
        $ Data.Map.Strict.toList
        $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs
  }
--- a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs
@ -1,69 +1,81 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Rank2Types #-}
-module System.Nix.Store.Remote.Server where
+module System.Nix.Store.Remote.Server
+  ( runProxyDaemon
+  , WorkerHelper
+  )
+  where

 import Control.Concurrent.Classy.Async
 import Control.Monad (join, void, when)
 import Control.Monad.Conc.Class (MonadConc)
 import Control.Monad.Except (MonadError, throwError)
-import Control.Monad.Reader (MonadReader, asks)
 import Control.Monad.Trans (lift)
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.Default.Class (Default(def))
 import Data.Foldable (traverse_)
 import Data.IORef (IORef, atomicModifyIORef, newIORef)
-import Data.Some (Some(Some))
 import Data.Text (Text)
 import Data.Void (Void, absurd)
 import Data.Word (Word32)
-import qualified Data.Text
-import qualified Data.Text.IO
 import Network.Socket (Socket, accept, close, listen, maxListenQueue)
-import System.Nix.StorePath (StoreDir)
-import System.Nix.Store.Remote.Serializer as RB
+import System.Nix.Nar (NarSource)
+import System.Nix.Store.Remote.Client (Run, doReq)
+import System.Nix.Store.Remote.Serializer (LoggerSError, mapErrorS, storeRequest, workerMagic, protoVersion, int, logger, text, trustedFlag)
 import System.Nix.Store.Remote.Socket
 import System.Nix.Store.Remote.Types.StoreRequest as R
-import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig(..), PreStoreConfig(..), preStoreConfigToStoreConfig)
-import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..))
+import System.Nix.Store.Remote.Types.StoreReply
+import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..))
 import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..))
-
-import System.Nix.Store.Remote.MonadStore (WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT, mapStoreConfig)
+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.ProtoVersion (ourProtoVersion)
 import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
+import qualified Data.Some
+import qualified Data.Text
+import qualified Data.Text.IO
+import qualified System.Timeout
+import qualified Network.Socket.ByteString

-type WorkerHelper m = forall a. StoreRequest a -> m a
+type WorkerHelper m
+  = forall a
+  . ( Show a
+    , StoreReply a
+    )
+  => RemoteStoreT m a
+  -> Run m a
+
+chatty :: Bool
+chatty = False
+
+dbg :: MonadIO m => Text -> m ()
+dbg = when chatty . liftIO . Data.Text.IO.putStrLn

 -- | Run an emulated nix daemon on given socket address.
 -- The deamon will close when the continuation returns.
-runDaemonSocket
+runProxyDaemon
  :: forall m a
  . ( MonadIO m
    , MonadConc m
-    , MonadError RemoteStoreError m
-    , MonadReader StoreConfig m
    )
-  => StoreDir
-  -> WorkerHelper m
+  => WorkerHelper m
+  -> RemoteStoreT m ()
  -> Socket
  -> m a
  -> m a
-runDaemonSocket sd workerHelper lsock k = do
+runProxyDaemon workerHelper postGreet lsock k = do
  liftIO $ listen lsock maxListenQueue

-  liftIO $ Data.Text.IO.putStrLn "listening"
+  dbg "listening"

  let listener :: m Void
      listener = do
        (sock, _) <- liftIO $ accept lsock
-        liftIO $ Data.Text.IO.putStrLn "accepting"
-
-        let preStoreConfig = PreStoreConfig
-              { preStoreConfig_socket = sock
-              , preStoreConfig_dir = sd
-              }
+        dbg "accepting"

        -- TODO: this, but without the space leak
-        fmap fst $ concurrently listener $ processConnection workerHelper preStoreConfig
+        fmap fst
+          $ concurrently listener
+          $ processConnection workerHelper postGreet sock

  either absurd id <$> race listener k

@ -71,59 +83,128 @@ runDaemonSocket sd workerHelper lsock k = do
 --
 -- this function should take care to not throw errors from client connections.
 processConnection
-  :: ( MonadIO m
-     , MonadError RemoteStoreError m
-     , MonadReader StoreConfig m
-     )
+  :: forall m
+  .  MonadIO m
  => WorkerHelper m
-  -> PreStoreConfig
+  -> RemoteStoreT m ()
+  -> Socket
  -> m ()
-processConnection workerHelper preStoreConfig = do
-  ~() <- void $ runRemoteStoreT preStoreConfig $ do
+processConnection workerHelper postGreet sock = do
+  ~() <- void $ runRemoteStoreT sock $ do

    ServerHandshakeOutput{..}
      <- greet
          ServerHandshakeInput
          { serverHandshakeInputNixVersion = "nixVersion (hnix-store-remote)"
-          , serverHandshakeInputOurVersion= ourProtoVersion
+          , serverHandshakeInputOurVersion = def
          , serverHandshakeInputTrust = Nothing
          }

-    mapStoreConfig
-      (preStoreConfigToStoreConfig
-        serverHandshakeOutputLeastCommonVersion)
-      $ do
+    setProtoVersion serverHandshakeOutputLeastCommonVersion

-        tunnelLogger <- liftIO $ newTunnelLogger
-        -- Send startup error messages to the client.
-        startWork tunnelLogger
+    tunnelLogger <- liftIO $ newTunnelLogger
+    -- Send startup error messages to the client.
+    startWork tunnelLogger

-        -- TODO: do we need auth at all? probably?
-        -- If we can't accept clientVersion, then throw an error *here* (not above).
-        --authHook(*store);
-        stopWork tunnelLogger
+    -- TODO: do we need auth at all? probably?
+    -- If we can't accept clientVersion, then throw an error *here* (not above).
+    --authHook(*store);
+    stopWork tunnelLogger

-        -- Process client requests.
-        let loop = do
-              someReq <-
-                sockGetS
-                  $ mapErrorS
-                      RemoteStoreError_SerializerRequest
-                      storeRequest
+    -- so we can set store dir
+    postGreet

-              lift $ performOp' workerHelper tunnelLogger someReq
-              loop
-        loop
+    let perform
+          :: ( Show a
+             , StoreReply a
+             )
+          => StoreRequest a
+          -> RemoteStoreT m ()
+        perform req = do

-  liftIO $ Data.Text.IO.putStrLn "daemon connection done"
-  liftIO $ close $ preStoreConfig_socket preStoreConfig
+          special <- case req of
+            AddToStore {} -> do
+              -- This is a hack (but a pretty neat and fast one!)
+              -- it should parse nad stream NAR instead
+              let proxyNarSource :: NarSource IO
+                  proxyNarSource f =
+                    liftIO
+                      (System.Timeout.timeout
+                         1000000
+                         (Network.Socket.ByteString.recv sock 8)
+                      )
+                    >>= \case
+                      Nothing -> pure ()
+                      Just x -> f x >> proxyNarSource f
+
+              pure $ setNarSource proxyNarSource
+            _ -> pure $ pure ()
+
+          res <-
+            bracketLogger
+              tunnelLogger
+              $ lift
+              $ workerHelper
+              $ special >> doReq req
+
+          case fst res of
+            Left e -> throwError e
+            Right reply ->
+              sockPutS
+                (mapErrorS
+                   RemoteStoreError_SerializerReply
+                   $ getReplyS
+                )
+                reply
+
+    -- Process client requests.
+    let loop = do
+          someReq <-
+            sockGetS
+              $ mapErrorS
+                  RemoteStoreError_SerializerRequest
+                  storeRequest
+
+          -- have to be explicit here
+          -- because otherwise GHC can't conjure Show a, StoreReply a
+          -- out of thin air
+          () <- Data.Some.withSome someReq $ \case
+            r@AddToStore {} -> perform r
+            r@AddTextToStore {} -> perform r
+            r@AddSignatures {} -> perform r
+            r@AddTempRoot {} -> perform r
+            r@AddIndirectRoot {} -> perform r
+            r@BuildDerivation {} -> perform r
+            r@BuildPaths {} -> perform r
+            r@CollectGarbage {} -> perform r
+            r@EnsurePath {} -> perform r
+            r@FindRoots {} -> perform r
+            r@IsValidPath {} -> perform r
+            r@QueryValidPaths {} -> perform r
+            r@QueryAllValidPaths {} -> perform r
+            r@QuerySubstitutablePaths {} -> perform r
+            r@QueryPathInfo {} -> perform r
+            r@QueryReferrers {} -> perform r
+            r@QueryValidDerivers {} -> perform r
+            r@QueryDerivationOutputs {} -> perform r
+            r@QueryDerivationOutputNames {} -> perform r
+            r@QueryPathFromHashPart {} -> perform r
+            r@QueryMissing {} -> perform r
+            r@OptimiseStore {} -> perform r
+            r@SyncWithGC {} -> perform r
+            r@VerifyStore {} -> perform r
+          loop
+    loop
+
+  dbg "daemon connection done"
+  liftIO $ close sock

  where
    -- Exchange the greeting.
    greet
      :: MonadIO m
      => ServerHandshakeInput
-      -> RemoteStoreT PreStoreConfig m ServerHandshakeOutput
+      -> RemoteStoreT m ServerHandshakeOutput
    greet ServerHandshakeInput{..} = do
      magic <-
        sockGetS
@ -131,7 +212,6 @@ processConnection workerHelper preStoreConfig = do
            RemoteStoreError_SerializerHandshake
            workerMagic

-      liftIO $ print ("magic" :: Text, magic)
      when (magic /= WorkerMagic_One)
        $ throwError
        $ RemoteStoreError_WorkerException
@ -148,9 +228,7 @@ processConnection workerHelper preStoreConfig = do

      clientVersion <- sockGetS protoVersion

-      let leastCommonVersion = min clientVersion ourProtoVersion
-
-      liftIO $ print ("Versions client, min" :: Text, clientVersion, leastCommonVersion)
+      let leastCommonVersion = min clientVersion serverHandshakeInputOurVersion

      when (clientVersion < ProtoVersion 1 10)
        $ throwError
@ -189,57 +267,13 @@ processConnection workerHelper preStoreConfig = do
        , serverHandshakeOutputClientVersion = clientVersion
        }

-simpleOp
-  :: ( MonadIO m
-     , HasStoreSocket r
-     , HasProtoVersion r
-     , MonadError RemoteStoreError m
-     , MonadReader r m
-     )
-  => (StoreRequest () -> m ())
-  -> TunnelLogger r
-  -> m (StoreRequest ())
-  -> m ()
-simpleOp workerHelper tunnelLogger m = do
-  req <- m
-  bracketLogger tunnelLogger $ workerHelper req
-  sockPutS
-    (mapErrorS
-       RemoteStoreError_SerializerPut
-       bool
-    )
-    True
-
-simpleOpRet
-  :: ( MonadIO m
-     , HasStoreSocket r
-     , HasProtoVersion r
-     , MonadError RemoteStoreError m
-     , MonadReader r m
-     )
-  => (StoreRequest a -> m a)
-  -> TunnelLogger r
-  -> NixSerializer r SError a
-  -> m (StoreRequest a)
-  -> m ()
-simpleOpRet workerHelper tunnelLogger s m = do
-  req <- m
-  resp <- bracketLogger tunnelLogger $ workerHelper req
-  sockPutS
-    (mapErrorS
-       RemoteStoreError_SerializerPut
-       s
-    )
-    resp
+{-# WARNING _unimplemented "not yet implemented" #-}
+_unimplemented :: RemoteStoreError
+_unimplemented = RemoteStoreError_WorkerException $ WorkerException_Error $ WorkerError_NotYetImplemented

 bracketLogger
-  :: ( MonadIO m
-     , HasStoreSocket r
-     , HasProtoVersion r
-     , MonadReader r m
-     , MonadError RemoteStoreError m
-     )
-  => TunnelLogger r
+  :: MonadRemoteStore m
+  => TunnelLogger
  -> m a
  -> m a
 bracketLogger tunnelLogger m = do
@ -248,81 +282,43 @@ bracketLogger tunnelLogger m = do
  stopWork tunnelLogger
  pure a

-{-# WARNING unimplemented "not yet implemented" #-}
-unimplemented :: WorkerException
-unimplemented = WorkerException_Error $ WorkerError_NotYetImplemented
-
-performOp'
-  :: forall m
-   . ( MonadIO m
-     , MonadError RemoteStoreError m
-     , MonadReader StoreConfig m
-     )
-  => WorkerHelper m
-  -> TunnelLogger StoreConfig
-  -> Some StoreRequest
-  -> m ()
-performOp' workerHelper tunnelLogger op = do
-  let _simpleOp' = simpleOp workerHelper tunnelLogger
-  let simpleOpRet'
-        :: NixSerializer StoreConfig SError a
-        -> m (StoreRequest a)
-        -> m ()
-      simpleOpRet' = simpleOpRet workerHelper tunnelLogger
-
-  case op of
-    Some (IsValidPath path) -> simpleOpRet' bool $ do
-      pure $ R.IsValidPath path
-
-    _ -> undefined
-
 ---

-data TunnelLogger r = TunnelLogger
-  { _tunnelLogger_state :: IORef (TunnelLoggerState r)
+data TunnelLogger = TunnelLogger
+  { _tunnelLogger_state :: IORef TunnelLoggerState
  }

-data TunnelLoggerState r = TunnelLoggerState
+data TunnelLoggerState = TunnelLoggerState
  { _tunnelLoggerState_canSendStderr :: Bool
  , _tunnelLoggerState_pendingMsgs :: [Logger]
  }

-newTunnelLogger :: IO (TunnelLogger r)
+newTunnelLogger :: IO TunnelLogger
 newTunnelLogger = TunnelLogger <$> newIORef (TunnelLoggerState False [])

 enqueueMsg
-  :: ( MonadIO m
-     , MonadReader r m
+  :: ( MonadRemoteStore m
     , MonadError LoggerSError m
-     , HasProtoVersion r
-     , HasStoreSocket r
     )
-  => TunnelLogger r
+  => TunnelLogger
  -> Logger
  -> m ()
 enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of
  True -> (st, sockPutS logger l)
  False -> (TunnelLoggerState c (l:p), pure ())

-log
-  :: ( MonadIO m
-     , MonadReader r m
-     , HasStoreSocket r
+_log
+  :: ( MonadRemoteStore m
     , MonadError LoggerSError m
-     , HasProtoVersion r
     )
-  => TunnelLogger r
+  => TunnelLogger
  -> Text
  -> m ()
-log l s = enqueueMsg l (Logger_Next s)
+_log l s = enqueueMsg l (Logger_Next s)

 startWork
-  :: (MonadIO m, MonadReader r m, HasStoreSocket r
-
-     , MonadError RemoteStoreError m
-     , HasProtoVersion r
-  )
-  => TunnelLogger r
+  :: MonadRemoteStore m
+  => TunnelLogger
  -> m ()
 startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,)
  (TunnelLoggerState True []) $
@ -330,12 +326,8 @@ startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,)
  where logger' = mapErrorS RemoteStoreError_SerializerLogger logger

 stopWork
-  :: (MonadIO m, MonadReader r m, HasStoreSocket r
-
-     , MonadError RemoteStoreError m
-     , HasProtoVersion r
-  )
-  => TunnelLogger r
+  :: MonadRemoteStore m
+  => TunnelLogger
  -> m ()
 stopWork x = updateLogger x $ \_ -> (,)
  (TunnelLoggerState False [])
@ -348,27 +340,24 @@ stopWork x = updateLogger x $ \_ -> (,)
 --
 -- Unlike 'stopWork', this function may be called at any time to (try) to end a
 -- session with an error.
-stopWorkOnError
-  :: (MonadIO m, MonadReader r m, HasStoreSocket r, HasProtoVersion r
-
-    , MonadError RemoteStoreError m
-  )
-  => TunnelLogger r
+_stopWorkOnError
+  :: MonadRemoteStore m
+  => TunnelLogger
  -> ErrorInfo
  -> m Bool
-stopWorkOnError x ex = updateLogger x $ \st ->
+_stopWorkOnError x ex = updateLogger x $ \st ->
  case _tunnelLoggerState_canSendStderr st of
    False -> (st, pure False)
    True -> (,) (TunnelLoggerState False []) $ do
-      asks hasProtoVersion >>= \pv -> if protoVersion_minor pv >= 26
+      getProtoVersion >>= \pv -> if protoVersion_minor pv >= 26
        then sockPutS logger' (Logger_Error (Right ex))
        else sockPutS logger' (Logger_Error (Left (BasicError 0 (Data.Text.pack $ show ex))))
      pure True
  where logger' = mapErrorS RemoteStoreError_SerializerLogger logger

 updateLogger
-  :: (MonadIO m, MonadReader r m, HasStoreSocket r)
-  => TunnelLogger r
-  -> (TunnelLoggerState r -> (TunnelLoggerState r, m a))
+  :: MonadRemoteStore m
+  => TunnelLogger
+  -> (TunnelLoggerState -> (TunnelLoggerState, m a))
  -> m a
 updateLogger x = join . liftIO . atomicModifyIORef (_tunnelLogger_state x)
--- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs
@ -2,14 +2,13 @@ module System.Nix.Store.Remote.Socket where

 import Control.Monad.Except (MonadError, throwError)
 import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Reader (MonadReader, ask, asks)
 import Data.ByteString (ByteString)
 import Data.Serialize.Get (Get, Result(..))
 import Data.Serialize.Put (Put, runPut)
 import Network.Socket.ByteString (recv, sendAll)
-import System.Nix.Store.Remote.MonadStore (MonadRemoteStoreR, RemoteStoreError(..))
+import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), RemoteStoreError(..))
 import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT)
-import System.Nix.Store.Remote.Types (HasStoreSocket(..))
+import System.Nix.Store.Remote.Types (ProtoStoreConfig)

 import qualified Control.Exception
 import qualified Data.ByteString
@ -47,14 +46,10 @@ genericIncremental getsome parser = do
        leftover

 sockGet8
-  :: ( MonadIO m
-     , MonadError RemoteStoreError m
-     , MonadReader r m
-     , HasStoreSocket r
-     )
+  :: MonadRemoteStore m
  => m ByteString
 sockGet8 = do
-  soc <- asks hasStoreSocket
+  soc <- getStoreSocket
  eresult <- liftIO $ Control.Exception.try $ recv soc 8
  case eresult of
    Left e ->
@ -67,46 +62,39 @@ sockGet8 = do
      pure result

 sockPut
-  :: ( MonadRemoteStoreR r m
-     , HasStoreSocket r
-     )
+  :: MonadRemoteStore m
  => Put
  -> m ()
 sockPut p = do
-  soc <- asks hasStoreSocket
+  soc <- getStoreSocket
  liftIO $ sendAll soc $ runPut p

 sockPutS
-  :: ( MonadReader r m
+  :: ( MonadRemoteStore m
     , MonadError e m
-     , MonadIO m
-     , HasStoreSocket r
     )
-  => NixSerializer r e a
+  => NixSerializer ProtoStoreConfig e a
  -> a
  -> m ()
 sockPutS s a = do
-  r <- ask
-  case runP s r a of
-    Right x -> liftIO $ sendAll (hasStoreSocket r) x
+  cfg <- getConfig
+  sock <- getStoreSocket
+  case runP s cfg a of
+    Right x -> liftIO $ sendAll sock x
    Left e -> throwError e

 sockGetS
-  :: forall r e m a
-   . ( HasStoreSocket r
-     , MonadError RemoteStoreError m
+  :: ( MonadRemoteStore m
     , MonadError e m
-     , MonadReader r m
-     , MonadIO m
     , Show a
     , Show e
     )
-  => NixSerializer r e a
+  => NixSerializer ProtoStoreConfig e a
  -> m a
 sockGetS s = do
-  r <- ask
+  cfg <- getConfig
  res <- genericIncremental sockGet8
-    $ runSerialT r $ Data.Serializer.getS s
+    $ runSerialT cfg $ Data.Serializer.getS s

  case res of
    Right x -> pure x
--- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs
@ -19,7 +19,7 @@ data ClientHandshakeInput = ClientHandshakeInput
 data ClientHandshakeOutput = ClientHandshakeOutput
  { clientHandshakeOutputNixVersion :: Maybe Text -- ^ Textual version, since 1.33
  , clientHandshakeOutputTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us
-  , clientHandshakeOutputLeastCommonVerison :: ProtoVersion -- ^ Minimum protocol version supported by both sides
+  , clientHandshakeOutputLeastCommonVersion :: ProtoVersion -- ^ Minimum protocol version supported by both sides
  , clientHandshakeOutputServerVersion :: ProtoVersion -- ^ Protocol version supported by the server
  } deriving (Eq, Generic, Ord, Show)

--- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs
@ -1,11 +1,11 @@
 module System.Nix.Store.Remote.Types.ProtoVersion
  ( ProtoVersion(..)
  , HasProtoVersion(..)
-  , ourProtoVersion
  ) where

+import Data.Default.Class (Default(def))
 import Data.Word (Word8, Word16)
-import GHC.Generics
+import GHC.Generics (Generic)

 data ProtoVersion = ProtoVersion
  { protoVersion_major :: Word16
@ -13,15 +13,15 @@ data ProtoVersion = ProtoVersion
  }
  deriving (Eq, Generic, Ord, Show)

+-- | The protocol version we support
+instance Default ProtoVersion where
+  def = ProtoVersion
+    { protoVersion_major = 1
+    , protoVersion_minor = 24
+    }
+
 class HasProtoVersion r where
  hasProtoVersion :: r -> ProtoVersion

 instance HasProtoVersion ProtoVersion where
  hasProtoVersion = id
-
-- | The protocol version we support
-ourProtoVersion :: ProtoVersion
-ourProtoVersion = ProtoVersion
-  { protoVersion_major = 1
-  , protoVersion_minor = 24
-  }
--- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs
@ -1,72 +1,61 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module System.Nix.Store.Remote.Types.StoreConfig
-  ( PreStoreConfig(..)
-  , StoreConfig(..)
-  , TestStoreConfig(..)
+  ( ProtoStoreConfig(..)
+  , StoreSocketPath(..)
+  , StoreTCP(..)
+  , StoreConnection(..)
  , HasStoreSocket(..)
-  , preStoreConfigToStoreConfig
  ) where

+import Data.Default.Class (Default(def))
+import Data.String (IsString)
 import GHC.Generics (Generic)
 import Network.Socket (Socket)
 import System.Nix.StorePath (HasStoreDir(..), StoreDir)
 import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion)

-data PreStoreConfig = PreStoreConfig
-  { preStoreConfig_dir :: StoreDir
-  , preStoreConfig_socket :: Socket
-  }
-
-instance HasStoreDir PreStoreConfig where
-  hasStoreDir = preStoreConfig_dir
-
 class HasStoreSocket r where
  hasStoreSocket :: r -> Socket

 instance HasStoreSocket Socket where
  hasStoreSocket = id

-instance HasStoreSocket PreStoreConfig where
-  hasStoreSocket = preStoreConfig_socket
+data ProtoStoreConfig = ProtoStoreConfig
+  { protoStoreConfigDir :: StoreDir
+  , protoStoreConfigProtoVersion :: ProtoVersion
+  } deriving (Eq, Generic, Ord, Show)

-data StoreConfig = StoreConfig
-  { storeConfig_dir :: StoreDir
-  , storeConfig_protoVersion :: ProtoVersion
-  , storeConfig_socket :: Socket
-  }
+instance Default ProtoStoreConfig where
+  def = ProtoStoreConfig def def

 instance HasStoreDir StoreDir where
  hasStoreDir = id

-instance HasStoreDir StoreConfig where
-  hasStoreDir = storeConfig_dir
+instance HasStoreDir ProtoStoreConfig where
+  hasStoreDir = protoStoreConfigDir

-instance HasProtoVersion StoreConfig where
-  hasProtoVersion = storeConfig_protoVersion
+instance HasProtoVersion ProtoStoreConfig where
+  hasProtoVersion = protoStoreConfigProtoVersion

-instance HasStoreSocket StoreConfig where
-  hasStoreSocket = storeConfig_socket
+newtype StoreSocketPath = StoreSocketPath
+  { unStoreSocketPath :: FilePath
+  }
+  deriving newtype (IsString)
+  deriving stock (Eq, Generic, Ord, Show)

-data TestStoreConfig = TestStoreConfig
-  { testStoreConfig_dir :: StoreDir
-  , testStoreConfig_protoVersion :: ProtoVersion
+instance Default StoreSocketPath where
+  def = StoreSocketPath "/nix/var/nix/daemon-socket/socket"
+
+data StoreTCP = StoreTCP
+  { storeTCPHost :: String
+  , storeTCPPort :: Int
  } deriving (Eq, Generic, Ord, Show)

-instance HasProtoVersion TestStoreConfig where
-  hasProtoVersion = testStoreConfig_protoVersion
+data StoreConnection
+  = StoreConnection_Socket StoreSocketPath
+  | StoreConnection_TCP StoreTCP
+  deriving (Eq, Generic, Ord, Show)

-instance HasStoreDir TestStoreConfig where
-  hasStoreDir = testStoreConfig_dir
-
-- | Convert @PreStoreConfig@ to @StoreConfig@
-- adding @ProtoVersion@ to latter
-preStoreConfigToStoreConfig
-  :: ProtoVersion
-  -> PreStoreConfig
-  -> StoreConfig
-preStoreConfigToStoreConfig pv PreStoreConfig{..} =
-  StoreConfig
-    { storeConfig_dir = preStoreConfig_dir
-    , storeConfig_protoVersion = pv
-    , storeConfig_socket = preStoreConfig_socket
-    }
+instance Default StoreConnection where
+  def = StoreConnection_Socket def
--- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs
+++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs
@ -5,12 +5,12 @@ module System.Nix.Store.Remote.Types.StoreReply
 import Data.HashSet (HashSet)
 import Data.Map (Map)
 import System.Nix.Build (BuildResult)
-import System.Nix.StorePath (HasStoreDir(..), StorePath, StorePathName)
+import System.Nix.StorePath (StorePath, StorePathName)
 import System.Nix.StorePath.Metadata (Metadata)
 import System.Nix.Store.Remote.Serializer
 import System.Nix.Store.Remote.Types.GC (GCResult, GCRoot)
 import System.Nix.Store.Remote.Types.Query.Missing (Missing)
-import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion)
+import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig)

 -- | Get @NixSerializer@ for some type @a@
 -- This could also be generalized for every type
@ -18,11 +18,7 @@ import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion)
 -- this for replies and it would make look serializers
 -- quite hodor, like @a <- getS get; b <- getS get@
 class StoreReply a where
-  getReplyS
-    :: ( HasStoreDir r
-       , HasProtoVersion r
-       )
-    => NixSerializer r ReplySError a
+  getReplyS :: NixSerializer ProtoStoreConfig ReplySError a

 instance StoreReply () where
  getReplyS = opSuccess
--- a/hnix-store-remote/tests-io/NixDaemonSpec.hs
+++ b/hnix-store-remote/tests-io/NixDaemonSpec.hs
@ -5,12 +5,15 @@ module NixDaemonSpec
  , spec
  ) where

+import Control.Exception (catch, SomeException)
 import Control.Monad (forM_, unless, void)
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Catch (MonadMask)
+import Control.Monad.Conc.Class (MonadConc)
+import Control.Monad.IO.Class (MonadIO, liftIO)
 import Crypto.Hash (SHA256)
 import Data.Some (Some(Some))
 import Data.Text (Text)
-import Test.Hspec (Spec, SpecWith, around, describe, context)
+import Test.Hspec (ActionWith, Spec, SpecWith, around, describe, context)
 import Test.Hspec.Expectations.Lifted
 import Test.Hspec.Nix (forceRight)
 import System.FilePath ((</>))
@ -21,7 +24,7 @@ import System.Nix.DerivedPath (DerivedPath(..))
 import System.Nix.StorePath (StoreDir(..), StorePath)
 import System.Nix.StorePath.Metadata (Metadata(..))
 import System.Nix.Store.Remote
-import System.Nix.Store.Remote.MonadStore (MonadRemoteStore)
+import System.Nix.Store.Remote.Server (WorkerHelper)
 import System.Process (CreateProcess(..), ProcessHandle)
 import qualified Control.Concurrent
 import qualified Control.Exception
@ -38,21 +41,19 @@ import qualified System.IO.Temp
 import qualified System.Linux.Namespaces
 import qualified System.Nix.StorePath
 import qualified System.Nix.Nar
-import qualified System.Nix.Store.Remote.MonadStore
 import qualified System.Posix.User
 import qualified System.Process
 import qualified Test.Hspec

 createProcessEnv
  :: FilePath
-  -> String
-  -> [String]
+  -> CreateProcess
  -> IO ProcessHandle
-createProcessEnv fp proc args = do
+createProcessEnv fp cp = do
  mPath         <- System.Environment.lookupEnv "PATH"

  (_, _, _, ph) <-
-    System.Process.createProcess (System.Process.proc proc args)
+    System.Process.createProcess cp
      { cwd = Just fp
      , env = Just $ mockedEnv mPath fp
      }
@ -106,19 +107,19 @@ error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e561612
 -}

 startDaemon
-  :: FilePath
-  -> IO (ProcessHandle, MonadStore a -> Run IO a)
+  :: FilePath -- ^ Temporary directory
+  -> IO (ProcessHandle, StoreConnection)
 startDaemon fp = do
  writeConf (fp </> "etc" </> "nix.conf")
-  procHandle <- createProcessEnv fp "nix-daemon" []
+  procHandle <-
+    createProcessEnv
+      fp
+      $ System.Process.proc "nix-daemon" mempty
+
  waitSocket sockFp 30
  pure ( procHandle
-       , runStoreOpts
-          sockFp
-          (StoreDir
-            $ Data.ByteString.Char8.pack
-            $ fp </> "store"
-          )
+       , StoreConnection_Socket
+          $ StoreSocketPath sockFp
       )
 where
  sockFp = fp </> "var/nix/daemon-socket/socket"
@ -146,10 +147,10 @@ enterNamespaces = do
    [ GroupMapping 0 gid 1 ]
    True

-withNixDaemon
-  :: ((MonadStore a -> Run IO a) -> IO a)
+withNixDaemon'
+  :: (FilePath -> StoreDir -> StoreConnection -> IO a)
  -> IO a
-withNixDaemon action =
+withNixDaemon' action =
  System.IO.Temp.withSystemTempDirectory "test-nix-store" $ \path -> do

    mapM_ (System.Directory.createDirectory . snd)
@ -157,17 +158,69 @@ withNixDaemon action =
            ((/= "NIX_REMOTE") . fst)
            $ mockedEnv Nothing path)

-    ini <- createProcessEnv path "nix-store" ["--init"]
+    ini <-
+      createProcessEnv
+        path
+        $ System.Process.shell
+            -- see long note above @startDaemon@
+            "nix-store --init 2>&1 | grep -v 'error: changing ownership'"
+
    void $ System.Process.waitForProcess ini

    writeFile (path </> "dummy") "Hello World"

    System.Directory.setCurrentDirectory path
+    let storeDir =
+          StoreDir
+          $ Data.ByteString.Char8.pack
+          $ path </> "store"

    Control.Exception.bracket
      (startDaemon path)
      (System.Process.terminateProcess . fst)
-      (action . snd)
+      (action path storeDir . snd)
+
+withNixDaemon
+  :: ( MonadIO m
+     , MonadMask m
+     )
+  => ((RemoteStoreT m a -> Run m a) -> IO a)
+  -> IO a
+withNixDaemon action =
+  withNixDaemon' $ \_tmpPath storeDir storeConn ->
+    action $ \(mstore :: RemoteStoreT m a) ->
+      runStoreConnection storeConn
+        ( setStoreDir storeDir
+          >> mstore
+        )
+
+withManInTheMiddleNixDaemon
+  :: forall m a
+   . ( MonadIO m
+     , MonadMask m
+     , MonadConc m
+     )
+  => ((RemoteStoreT m a -> Run m a) -> IO a)
+  -> IO a
+withManInTheMiddleNixDaemon action =
+  withNixDaemon' $ \tmpPath storeDir storeConn ->
+  let
+    sockFp2 = tmpPath </> "var/nix/daemon-socket/socket2"
+    storeConn2 = StoreConnection_Socket $ StoreSocketPath sockFp2
+
+    handler :: WorkerHelper m
+    handler =
+      runStoreConnection storeConn
+      . (setStoreDir storeDir >>)
+
+  in action $ \(mstore :: RemoteStoreT m a) ->
+    runDaemonConnection handler
+      (setStoreDir storeDir)
+      storeConn2
+      $ runStoreConnection storeConn2
+          ( setStoreDir storeDir
+            >> mstore
+          )

 checks
  :: ( Show a
@ -211,8 +264,9 @@ itLefts
 itLefts name action = it name action Data.Either.isLeft

 withPath
-  :: (StorePath -> MonadStore a)
-  -> MonadStore a
+  :: MonadRemoteStore m
+  => (StorePath -> m a)
+  -> m a
 withPath action = do
  path <-
    addTextToStore
@ -225,7 +279,7 @@ withPath action = do
  action path

 -- | dummy path, adds <tmp>/dummy with "Hello World" contents
-dummy :: MonadStore StorePath
+dummy :: MonadRemoteStore m => m StorePath
 dummy = do
  addToStore
    (forceRight $ System.Nix.StorePath.mkStorePathName "dummy")
@ -250,7 +304,10 @@ _withBuilder
 _withBuilder action = do
  path <-
    addTextToStore
-      (StoreText (forceRight $ System.Nix.StorePath.mkStorePathName "builder") builderSh)
+      (StoreText
+        (forceRight $ System.Nix.StorePath.mkStorePathName "builder")
+        builderSh
+      )
      mempty
      RepairMode_DontRepair
  action path
@ -259,139 +316,175 @@ builderSh :: Text
 builderSh = "declare -xpexport > $out"

 spec :: Spec
-spec = around withNixDaemon $
+spec = do
+  describe "Remote store protocol" $ do
+    describe "Direct"
+      $ makeProtoSpec
+          withNixDaemon
+          SpecFlavor_Direct
+    describe "MITM"
+      $ makeProtoSpec
+          withManInTheMiddleNixDaemon
+          SpecFlavor_MITM

-  describe "store" $ do
+data SpecFlavor
+  = SpecFlavor_Direct
+  | SpecFlavor_MITM
+  deriving (Eq, Ord, Show)

-    context "syncWithGC" $
-      itRights "syncs with garbage collector" syncWithGC
+makeProtoSpec
+  :: (ActionWith
+       (RemoteStoreT IO () -> Run IO ())
+       -> IO ()
+     )
+  -> SpecFlavor
+  -> Spec
+makeProtoSpec f flavor = around f $ do
+  context "syncWithGC" $
+    itRights "syncs with garbage collector" syncWithGC

-    context "verifyStore" $ do
-      itRights "check=False repair=False" $
-        verifyStore
-          CheckMode_DontCheck
-          RepairMode_DontRepair
-        `shouldReturn` False
+  context "verifyStore" $ do
+    itRights "check=False repair=False" $
+      verifyStore
+        CheckMode_DontCheck
+        RepairMode_DontRepair
+      `shouldReturn` False

-      itRights "check=True repair=False" $
-        verifyStore
-          CheckMode_DoCheck
-          RepairMode_DontRepair
-        `shouldReturn` False
+    itRights "check=True repair=False" $
+      verifyStore
+        CheckMode_DoCheck
+        RepairMode_DontRepair
+      `shouldReturn` False

-      --privileged
-      itRights "check=True repair=True" $
-        verifyStore
-          CheckMode_DoCheck
-          RepairMode_DoRepair
-        `shouldReturn` False
+    --privileged
+    itRights "check=True repair=True" $
+      verifyStore
+        CheckMode_DoCheck
+        RepairMode_DoRepair
+      `shouldReturn` False

-    context "addTextToStore" $
-      itRights "adds text to store" $ withPath pure
+  context "addTextToStore" $
+    itRights "adds text to store" $ withPath pure

-    context "isValidPath" $ do
-      itRights "validates path" $ withPath $ \path -> do
-        liftIO $ print path
-        isValidPath path `shouldReturn` True
-      itLefts "fails on invalid path"
-        $ System.Nix.Store.Remote.MonadStore.mapStoreConfig
-            (\sc -> sc { storeConfig_dir = StoreDir "/asdf" })
-            $ isValidPath invalidPath
+  context "isValidPath" $ do
+    itRights "validates path" $ withPath $ \path -> do
+      isValidPath path `shouldReturn` True

-    context "queryAllValidPaths" $ do
-      itRights "empty query" queryAllValidPaths
-      itRights "non-empty query" $ withPath $ \path ->
-        queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path]
+    itLefts "fails on invalid path" $ do
+      setStoreDir (StoreDir "/asdf")
+      isValidPath invalidPath

-    context "queryPathInfo" $
-      itRights "queries path info" $ withPath $ \path -> do
-        meta <- queryPathInfo path
-        (metadataReferences <$> meta) `shouldBe` (Just mempty)
+  context "queryAllValidPaths" $ do
+    itRights "empty query" queryAllValidPaths
+    itRights "non-empty query" $ withPath $ \path ->
+      queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path]

-    context "ensurePath" $
-      itRights "simple ensure" $ withPath ensurePath
+  context "queryPathInfo" $
+    itRights "queries path info" $ withPath $ \path -> do
+      meta <- queryPathInfo path
+      (metadataReferences <$> meta) `shouldBe` (Just mempty)

-    context "addTempRoot" $
-      itRights "simple addition" $ withPath addTempRoot
+  context "ensurePath" $
+    itRights "simple ensure" $ withPath ensurePath

-    context "addIndirectRoot" $
-      itRights "simple addition" $ withPath addIndirectRoot
+  context "addTempRoot" $
+    itRights "simple addition" $ withPath addTempRoot

-    let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p]
+  context "addIndirectRoot" $
+    itRights "simple addition" $ withPath addIndirectRoot

-    context "buildPaths" $ do
-      itRights "build Normal" $ withPath $ \path -> do
-        buildPaths (toDerivedPathSet path) BuildMode_Normal
+  let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p]

-      itRights "build Check" $ withPath $ \path -> do
-        buildPaths (toDerivedPathSet path) BuildMode_Check
+  context "buildPaths" $ do
+    itRights "build Normal" $ withPath $ \path -> do
+      buildPaths (toDerivedPathSet path) BuildMode_Normal

-      itLefts "build Repair" $ withPath $ \path -> do
-        buildPaths (toDerivedPathSet path) BuildMode_Repair
+    itRights "build Check" $ withPath $ \path -> do
+      buildPaths (toDerivedPathSet path) BuildMode_Check

-    context "roots" $ context "findRoots" $ do
-        itRights "empty roots" (findRoots `shouldReturn` mempty)
+    itLefts "build Repair" $ withPath $ \path -> do
+      buildPaths (toDerivedPathSet path) BuildMode_Repair

-        itRights "path added as a temp root" $ withPath $ \_ -> do
-          roots <- findRoots
-          roots `shouldSatisfy` ((== 1) . Data.Map.size)
+  context "roots" $ context "findRoots" $ do
+    itRights "empty roots" (findRoots `shouldReturn` mempty)

-    context "optimiseStore" $ itRights "optimises" optimiseStore
+    itRights "path added as a temp root" $ withPath $ \_ -> do
+      let expectRoots =
+            if flavor == SpecFlavor_MITM
+            then 0 -- nested client closes its connection so temp root gets removed
+            else 1
+      roots <- findRoots
+      roots `shouldSatisfy` ((== expectRoots) . Data.Map.size)

-    context "queryMissing" $
-      itRights "queries" $ withPath $ \path -> do
-        queryMissing (toDerivedPathSet path)
-        `shouldReturn`
-        Missing
-          { missingWillBuild = mempty
-          , missingWillSubstitute = mempty
-          , missingUnknownPaths = mempty
-          , missingDownloadSize = 0
-          , missingNarSize = 0
-          }
+    itRights "indirect root" $ withPath $ \path -> do
+      let expectRoots =
+            if flavor == SpecFlavor_MITM
+            then 1 -- nested client closes its connection so temp root gets removed
+            else 2
+      addIndirectRoot path
+      roots <- findRoots
+      roots `shouldSatisfy` ((== expectRoots) . Data.Map.size)

-    context "addToStore" $
-      itRights "adds file to store" $ do
-        fp <-
-          liftIO
-          $ System.IO.Temp.writeSystemTempFile
-              "addition"
-              "yolo"
+  context "optimiseStore" $ itRights "optimises" optimiseStore

-        addToStore
-          (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition")
-          (System.Nix.Nar.dumpPath fp)
-          FileIngestionMethod_Flat
-          (Some HashAlgo_SHA256)
-          RepairMode_DontRepair
+  context "queryMissing" $
+    itRights "queries" $ withPath $ \path -> do
+      queryMissing (toDerivedPathSet path)
+      `shouldReturn`
+      Missing
+        { missingWillBuild = mempty
+        , missingWillSubstitute = mempty
+        , missingUnknownPaths = mempty
+        , missingDownloadSize = 0
+        , missingNarSize = 0
+        }

-    context "with dummy" $ do
-      itRights "adds dummy" dummy
+  context "addToStore" $
+    itRights "adds file to store" $ do
+      fp <-
+        liftIO
+        $ System.IO.Temp.writeSystemTempFile
+            "addition"
+            "yolo"

-      itRights "valid dummy" $ do
-        path <- dummy
-        isValidPath path `shouldReturn` True
+      addToStore
+        (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition")
+        (System.Nix.Nar.dumpPath fp)
+        FileIngestionMethod_Flat
+        (Some HashAlgo_SHA256)
+        RepairMode_DontRepair

-    context "collectGarbage" $ do
-      itRights "delete a specific path from the store" $ withPath $ \path -> do
-          -- clear temp gc roots so the delete works. restarting the nix daemon should also do this...
-          storeDir <- getStoreDir
-          let tempRootsDir = Data.Text.unpack $ mconcat [ Data.Text.Encoding.decodeUtf8 (unStoreDir storeDir), "/../var/nix/temproots/" ]
+  context "with dummy" $ do
+    itRights "adds dummy" dummy
+
+    itRights "valid dummy" $ do
+      path <- dummy
+      isValidPath path `shouldReturn` True
+
+  context "collectGarbage" $ do
+    itRights "deletes a specific path from the store" $ withPath $ \path -> do
+        -- clear temp gc roots so the delete works. restarting the nix daemon should also do this...
+        storeDir <- getStoreDir
+        let tempRootsDir = Data.Text.unpack $ mconcat [ Data.Text.Encoding.decodeUtf8 (unStoreDir storeDir), "/../var/nix/temproots/" ]
+        liftIO $ do
          tempRootList <-
-            liftIO
-            $ System.Directory.listDirectory
-                tempRootsDir
-          liftIO $ forM_ tempRootList $ \entry -> do
+            System.Directory.listDirectory tempRootsDir
+          forM_ tempRootList $ \entry -> do
            System.Directory.removeFile
              $ mconcat [ tempRootsDir, "/", entry ]
+            -- for MITM, the temp root will get deleted
+            -- by the daemon as our nested client exists
+            -- but the listDirectory might still see it
+            -- causing TOC/TOU flakiness
+            `catch` (\(_e :: SomeException) -> pure ())

-          GCResult{..} <-
-            collectGarbage
-              GCOptions
-                { gcOptionsOperation = GCAction_DeleteSpecific
-                , gcOptionsIgnoreLiveness = False
-                , gcOptionsPathsToDelete = Data.HashSet.fromList [path]
-                , gcOptionsMaxFreed = maxBound
-                }
-          gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path]
-          gcResultBytesFreed `shouldBe` 4
+        GCResult{..} <-
+          collectGarbage
+            GCOptions
+              { gcOptionsOperation = GCAction_DeleteSpecific
+              , gcOptionsIgnoreLiveness = False
+              , gcOptionsPathsToDelete = Data.HashSet.fromList [path]
+              , gcOptionsMaxFreed = maxBound
+              }
+        gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path]
+        gcResultBytesFreed `shouldBe` 4
--- a/hnix-store-remote/tests/NixSerializerSpec.hs
+++ b/hnix-store-remote/tests/NixSerializerSpec.hs
@ -17,7 +17,7 @@ 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 (TestStoreConfig(..))
+import System.Nix.Store.Remote.Types.StoreConfig (ProtoStoreConfig(..))
 import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))

 -- | Test for roundtrip using @NixSerializer@
@ -71,7 +71,7 @@ spec = parallel $ do
      prop "< 1.28"
        $ \sd -> forAll (arbitrary `suchThat` ((< 28) . protoVersion_minor))
        $ \pv ->
-            roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv)
+            roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv)
            . (\x -> x { buildResultBuiltOutputs = Nothing })
            . (\x -> x { buildResultTimesBuilt = Nothing
                       , buildResultIsNonDeterministic = Nothing
@ -81,7 +81,7 @@ spec = parallel $ do
              )
      prop "= 1.28"
        $ \sd ->
-            roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd (ProtoVersion 1 28))
+            roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd (ProtoVersion 1 28))
            . (\x -> x { buildResultTimesBuilt = Nothing
                       , buildResultIsNonDeterministic = Nothing
                       , buildResultStartTime = Nothing
@ -91,7 +91,7 @@ spec = parallel $ do
      prop "> 1.28"
        $ \sd -> forAll (arbitrary `suchThat` ((> 28) . protoVersion_minor))
        $ \pv ->
-            roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv)
+            roundtripSReader @ProtoStoreConfig buildResult (ProtoStoreConfig sd pv)

    prop "StorePath" $
      roundtripSReader @StoreDir storePath
@ -147,7 +147,7 @@ spec = parallel $ do
    prop "StoreRequest"
      $ \testStoreConfig ->
          forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig)))
-          $ roundtripSReader @TestStoreConfig storeRequest testStoreConfig
+          $ roundtripSReader @ProtoStoreConfig storeRequest testStoreConfig

  describe "StoreReply" $ do
    prop "()" $ roundtripS opSuccess