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

Some more server

docs/01-Contributors.org

@@ -31,3 +31,4 @@ in order of appearance:
 + Ryan Trinkle @ryantrinkle
 + Travis Whitaker @TravisWhitaker
 + Andrea Bedini @andreabedini
++ Dan Bornside @danbornside

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 =

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)@
+-- we will use @RealisationWithId@ newtype
--- instead.
 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)

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
+instance ToJSON RealisationWithId where
-  toJSON (drvOut, r) =
+  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

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
 ```

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"

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

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
+  , runStoreConnection
-  , runStoreOptsTCP
+  , 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
-import System.Nix.Store.Remote.MonadStore (RemoteStoreT, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed))
+  ( 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
-runStore = runStoreOpts defaultSockPath def
+  :: ( MonadIO m
-  where
+     , MonadMask m
-    defaultSockPath :: String
+     )
-    defaultSockPath = "/nix/var/nix/daemon-socket/socket"
+  => RemoteStoreT m a
+  -> Run m a
+runStore = runStoreConnection def
 
-runStoreOpts
+runStoreConnection
-  :: FilePath
+  :: ( MonadIO m
-  -> StoreDir
+     , MonadMask m
-  -> MonadStore a
+     )
-  -> Run IO a
+  => StoreConnection
-runStoreOpts socketPath =
+  -> RemoteStoreT m a
-  runStoreOpts'
+  -> Run m a
-    Network.Socket.AF_UNIX
+runStoreConnection sc k =
-    (SockAddrUnix socketPath)
+  connectionToSocket sc
+  >>= \case
+    Left e -> pure (Left e, mempty)
+    Right (fam, sock) -> runStoreSocket fam sock k
 
-runStoreOptsTCP
+runStoreSocket
-  :: String
+  :: ( MonadIO m
-  -> Int
+     , MonadMask m
-  -> StoreDir
+     )
-  -> MonadStore a
+  => Family
-  -> 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
   -> SockAddr
-  -> StoreDir
+  -> RemoteStoreT m a
-  -> MonadStore a
+  -> Run m a
-  -> Run IO a
+runStoreSocket sockFamily sockAddr code =
-runStoreOpts' sockFamily sockAddr storeRootDir code =
+  Control.Monad.Catch.bracket
-  Control.Exception.bracket
+    (liftIO open)
-    open
+    (liftIO . Network.Socket.close . hasStoreSocket)
-    (Network.Socket.close . hasStoreSocket)
+    (\s -> runRemoteStoreT s $ greetServer >> code)
-    (flip runStoreSocket 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
+      pure soc
-          { preStoreConfig_socket = soc
+
-          , preStoreConfig_dir = storeRootDir
+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)

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
+deriving via GenericArbitrary ProtoStoreConfig
-  instance Arbitrary TestStoreConfig
+  instance Arbitrary ProtoStoreConfig
 
 deriving via GenericArbitrary ProtoVersion
   instance Arbitrary ProtoVersion

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.
 --

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.ProtoVersion (ProtoVersion(..))
-import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig)
 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
+greetServer
-  :: ( Monad m
+  :: MonadRemoteStore m
-     , MonadIO m
+  => m ClientHandshakeOutput
-     )
+greetServer = do
-  => PreStoreConfig
+  sockPutS
-  -> RemoteStoreT StoreConfig m a
+    (mapErrorS
-  -> Run m a
+      RemoteStoreError_SerializerHandshake
-runStoreSocket preStoreConfig code =
+      workerMagic
-  runRemoteStoreT preStoreConfig $ do
+    )
-    ClientHandshakeOutput{..}
+    WorkerMagic_One
-      <- greet
-          ClientHandshakeInput
-          { clientHandshakeInputOurVersion = ourProtoVersion
-          }
 
-    mapStoreConfig
+  magic <-
-      (preStoreConfigToStoreConfig
+    sockGetS
-        clientHandshakeOutputLeastCommonVerison)
+    $ mapErrorS
-      code
+        RemoteStoreError_SerializerHandshake
+        workerMagic
 
-  where
+  unless
-    greet
+    (magic == WorkerMagic_Two)
-      :: MonadIO m
+    $ throwError RemoteStoreError_WorkerMagic2Mismatch
-      => ClientHandshakeInput
-      -> RemoteStoreT PreStoreConfig m ClientHandshakeOutput
-    greet ClientHandshakeInput{..} = do
 
-      sockPutS
+  daemonVersion <- sockGetS protoVersion
-        (mapErrorS
-          RemoteStoreError_SerializerHandshake
-          workerMagic
-        )
-        WorkerMagic_One
 
-      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
+          $ mapErrorS
-            RemoteStoreError_SerializerHandshake
+              RemoteStoreError_SerializerGet
-            workerMagic
+              text
+      pure $ Just txtVer
+    else pure Nothing
 
-      unless
+  remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35
-        (magic == WorkerMagic_Two)
+    then do
-        $ throwError RemoteStoreError_WorkerMagic2Mismatch
+      sockGetS
+        $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag
+    else pure Nothing
 
-      daemonVersion <- sockGetS protoVersion
+  setProtoVersion leastCommonVersion
+  processOutput
 
-      when (daemonVersion < ProtoVersion 1 10)
+  pure ClientHandshakeOutput
-        $ throwError RemoteStoreError_ClientVersionTooOld
+    { clientHandshakeOutputNixVersion = daemonNixVersion
-
+    , clientHandshakeOutputTrust = remoteTrustsUs
-      sockPutS protoVersion clientHandshakeInputOurVersion
+    , clientHandshakeOutputLeastCommonVersion = leastCommonVersion
-
+    , clientHandshakeOutputServerVersion = daemonVersion
-      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
-        }

hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs

@@ -8,22 +8,21 @@ module System.Nix.Store.Remote.MonadStore
   , WorkerException(..)
   , RemoteStoreT
   , runRemoteStoreT
-  , mapStoreConfig
+  , MonadRemoteStore(..)
-  , MonadRemoteStoreR(..)
-  , MonadRemoteStore
-  , getProtoVersion
   ) 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.Reader (MonadReader, ask)
-import Control.Monad.State.Strict (get, modify)
+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.State.Strict (StateT, runStateT)
-import Control.Monad.Trans.Except (ExceptT, runExceptT, mapExceptT)
+import Control.Monad.Trans.Except (ExceptT, runExceptT)
-import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT)
+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
+    remoteStoreStateConfig :: ProtoStoreConfig
-  , remoteStoreState_gotError :: Bool
+  , remoteStoreStateLogs :: DList Logger
-  , remoteStoreState_mDataSource :: Maybe (Word64 -> IO (Maybe ByteString))
+  , 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_NoDataSourceProvided -- remoteStoreStateMDataSource is required but it is Nothing
-  | RemoteStoreError_DataSourceExhausted -- remoteStoreState_mDataSource returned Nothing but more data was requested
+  | RemoteStoreError_DataSourceExhausted -- remoteStoreStateMDataSource returned Nothing but more data was requested
-  | RemoteStoreError_NoDataSinkProvided -- remoteStoreState_mDataSink is required but it is Nothing
+  | 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
+  :: Monad m
-     , HasStoreSocket r
+  => Socket
-     , Monad m
+  -> RemoteStoreT m a
-     )
-  => r
-  -> RemoteStoreT r m a
   -> m (Either RemoteStoreError a, DList Logger)
-runRemoteStoreT r =
+runRemoteStoreT sock =
-    fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreState_logs))
+    fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreStateLogs))
-  . (`runReaderT` r)
+  . (`runReaderT` sock)
   . (`runStateT` emptyState)
   . runExceptT
   . _unRemoteStoreT
   where
     emptyState = RemoteStoreState
-      { remoteStoreState_logs = mempty
+      { remoteStoreStateConfig = def
-      , remoteStoreState_gotError = False
+      , remoteStoreStateLogs = mempty
-      , remoteStoreState_mDataSource = Nothing
+      , remoteStoreStateMDataSource = Nothing
-      , remoteStoreState_mDataSink = Nothing
+      , remoteStoreStateMDataSink = Nothing
-      , remoteStoreState_mNarSource = 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 MonadRemoteStore m => MonadRemoteStore (StateT s m)
-instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ReaderT r m)
+instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m)
-instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ExceptT RemoteStoreError m)
+instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m)
 
-type MonadRemoteStore m = MonadRemoteStoreR StoreConfig m
+instance MonadIO m => MonadRemoteStore (RemoteStoreT m) where
 
-instance ( MonadIO m
+  getConfig = RemoteStoreT $ gets remoteStoreStateConfig
-         , HasStoreDir r
+  getProtoVersion = RemoteStoreT $ gets hasProtoVersion
-         , HasStoreSocket r
+  setProtoVersion pv =
-         )
+    RemoteStoreT $ modify $ \s ->
-         => MonadRemoteStoreR r (RemoteStoreT r m) where
+      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 = RemoteStoreT ask
-  getStoreSocket = hasStoreSocket <$> 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 }
+  setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = pure x }
-  getDataSource = remoteStoreState_mDataSource <$> RemoteStoreT get
+  getDataSource = RemoteStoreT (gets remoteStoreStateMDataSource)
-  clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = Nothing }
+  clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSource = Nothing }
 
-  setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = pure x }
+  setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreStateMDataSink = pure x }
-  getDataSink = remoteStoreState_mDataSink <$> RemoteStoreT get
+  getDataSink = RemoteStoreT (gets remoteStoreStateMDataSink)
-  clearDataSink = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = Nothing }
+  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
+    x <- remoteStoreStateMNarSource <$> get
-    modify $ \s -> s { remoteStoreState_mNarSource = Nothing }
+    modify $ \s -> s { remoteStoreStateMNarSource = Nothing }
     pure x
-
--- | Ask for a @StoreDir@
-getProtoVersion
-  :: ( MonadRemoteStoreR r m
-     , HasProtoVersion r
-     )
-  => m ProtoVersion
-getProtoVersion = asks hasProtoVersion

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
   }

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.Nar (NarSource)
-import System.Nix.Store.Remote.Serializer as RB
+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.StoreReply
-import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..))
+import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..))
 import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..))
-
+import System.Nix.Store.Remote.MonadStore (MonadRemoteStore(..), WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT)
-import System.Nix.Store.Remote.MonadStore (WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT, mapStoreConfig)
 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"
+        dbg "accepting"
-
-        let preStoreConfig = PreStoreConfig
-              { preStoreConfig_socket = sock
-              , preStoreConfig_dir = sd
-              }
 
         -- 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
+  :: forall m
-     , MonadError RemoteStoreError m
+  .  MonadIO m
-     , MonadReader StoreConfig m
-     )
   => WorkerHelper m
-  -> PreStoreConfig
+  -> RemoteStoreT m ()
+  -> Socket
   -> m ()
-processConnection workerHelper preStoreConfig = do
+processConnection workerHelper postGreet sock = do
-  ~() <- void $ runRemoteStoreT preStoreConfig $ do
+  ~() <- void $ runRemoteStoreT sock $ do
 
     ServerHandshakeOutput{..}
       <- greet
           ServerHandshakeInput
           { serverHandshakeInputNixVersion = "nixVersion (hnix-store-remote)"
-          , serverHandshakeInputOurVersion= ourProtoVersion
+          , serverHandshakeInputOurVersion = def
           , serverHandshakeInputTrust = Nothing
           }
 
-    mapStoreConfig
+    setProtoVersion serverHandshakeOutputLeastCommonVersion
-      (preStoreConfigToStoreConfig
-        serverHandshakeOutputLeastCommonVersion)
-      $ do
 
-        tunnelLogger <- liftIO $ newTunnelLogger
+    tunnelLogger <- liftIO $ newTunnelLogger
-        -- Send startup error messages to the client.
+    -- Send startup error messages to the client.
-        startWork tunnelLogger
+    startWork tunnelLogger
 
-        -- TODO: do we need auth at all? probably?
+    -- TODO: do we need auth at all? probably?
-        -- If we can't accept clientVersion, then throw an error *here* (not above).
+    -- If we can't accept clientVersion, then throw an error *here* (not above).
-        --authHook(*store);
+    --authHook(*store);
-        stopWork tunnelLogger
+    stopWork tunnelLogger
 
-        -- Process client requests.
+    -- so we can set store dir
-        let loop = do
+    postGreet
-              someReq <-
-                sockGetS
-                  $ mapErrorS
-                      RemoteStoreError_SerializerRequest
-                      storeRequest
 
-              lift $ performOp' workerHelper tunnelLogger someReq
+    let perform
-              loop
+          :: ( Show a
-        loop
+             , StoreReply a
+             )
+          => StoreRequest a
+          -> RemoteStoreT m ()
+        perform req = do
 
-  liftIO $ Data.Text.IO.putStrLn "daemon connection done"
+          special <- case req of
-  liftIO $ close $ preStoreConfig_socket preStoreConfig
+            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
+      let leastCommonVersion = min clientVersion serverHandshakeInputOurVersion
-
-      liftIO $ print ("Versions client, min" :: Text, clientVersion, leastCommonVersion)
 
       when (clientVersion < ProtoVersion 1 10)
         $ throwError
@@ -189,57 +267,13 @@ processConnection workerHelper preStoreConfig = do
         , serverHandshakeOutputClientVersion = clientVersion
         }
 
-simpleOp
+{-# WARNING _unimplemented "not yet implemented" #-}
-  :: ( MonadIO m
+_unimplemented :: RemoteStoreError
-     , HasStoreSocket r
+_unimplemented = RemoteStoreError_WorkerException $ WorkerException_Error $ WorkerError_NotYetImplemented
-     , 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
 
 bracketLogger
-  :: ( MonadIO m
+  :: MonadRemoteStore m
-     , HasStoreSocket r
+  => TunnelLogger
-     , HasProtoVersion r
-     , MonadReader r m
-     , MonadError RemoteStoreError m
-     )
-  => TunnelLogger r
   -> 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
+data TunnelLogger = TunnelLogger
-  { _tunnelLogger_state :: IORef (TunnelLoggerState r)
+  { _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
+  :: ( MonadRemoteStore m
-     , MonadReader r 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
+_log
-  :: ( MonadIO m
+  :: ( MonadRemoteStore m
-     , MonadReader r m
-     , HasStoreSocket r
      , 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
+  :: MonadRemoteStore m
-
+  => TunnelLogger
-     , MonadError RemoteStoreError m
-     , HasProtoVersion r
-  )
-  => TunnelLogger r
   -> 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
+  :: MonadRemoteStore m
-
+  => TunnelLogger
-     , MonadError RemoteStoreError m
-     , HasProtoVersion r
-  )
-  => TunnelLogger r
   -> 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
+_stopWorkOnError
-  :: (MonadIO m, MonadReader r m, HasStoreSocket r, HasProtoVersion r
+  :: MonadRemoteStore m
-
+  => TunnelLogger
-    , MonadError RemoteStoreError m
-  )
-  => TunnelLogger r
   -> 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)
+  :: MonadRemoteStore m
-  => TunnelLogger r
+  => TunnelLogger
-  -> (TunnelLoggerState r -> (TunnelLoggerState r, m a))
+  -> (TunnelLoggerState -> (TunnelLoggerState, m a))
   -> m a
 updateLogger x = join . liftIO . atomicModifyIORef (_tunnelLogger_state x)

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
+  :: MonadRemoteStore m
-     , MonadError RemoteStoreError m
-     , MonadReader r m
-     , HasStoreSocket r
-     )
   => 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
+  :: MonadRemoteStore m
-     , HasStoreSocket r
-     )
   => 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
+  cfg <- getConfig
-  case runP s r a of
+  sock <- getStoreSocket
-    Right x -> liftIO $ sendAll (hasStoreSocket r) x
+  case runP s cfg a of
+    Right x -> liftIO $ sendAll sock x
     Left e -> throwError e
 
 sockGetS
-  :: forall r e m a
+  :: ( MonadRemoteStore m
-   . ( HasStoreSocket r
-     , MonadError RemoteStoreError 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

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)
 

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
-  }

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(..)
+  ( ProtoStoreConfig(..)
-  , StoreConfig(..)
+  , StoreSocketPath(..)
-  , TestStoreConfig(..)
+  , 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
+data ProtoStoreConfig = ProtoStoreConfig
-  hasStoreSocket = preStoreConfig_socket
+  { protoStoreConfigDir :: StoreDir
+  , protoStoreConfigProtoVersion :: ProtoVersion
+  } deriving (Eq, Generic, Ord, Show)
 
-data StoreConfig = StoreConfig
+instance Default ProtoStoreConfig where
-  { storeConfig_dir :: StoreDir
+  def = ProtoStoreConfig def def
-  , storeConfig_protoVersion :: ProtoVersion
-  , storeConfig_socket :: Socket
-  }
 
 instance HasStoreDir StoreDir where
   hasStoreDir = id
 
-instance HasStoreDir StoreConfig where
+instance HasStoreDir ProtoStoreConfig where
-  hasStoreDir = storeConfig_dir
+  hasStoreDir = protoStoreConfigDir
 
-instance HasProtoVersion StoreConfig where
+instance HasProtoVersion ProtoStoreConfig where
-  hasProtoVersion = storeConfig_protoVersion
+  hasProtoVersion = protoStoreConfigProtoVersion
 
-instance HasStoreSocket StoreConfig where
+newtype StoreSocketPath = StoreSocketPath
-  hasStoreSocket = storeConfig_socket
+  { unStoreSocketPath :: FilePath
+  }
+  deriving newtype (IsString)
+  deriving stock (Eq, Generic, Ord, Show)
 
-data TestStoreConfig = TestStoreConfig
+instance Default StoreSocketPath where
-  { testStoreConfig_dir :: StoreDir
+  def = StoreSocketPath "/nix/var/nix/daemon-socket/socket"
-  , testStoreConfig_protoVersion :: ProtoVersion
+
+data StoreTCP = StoreTCP
+  { storeTCPHost :: String
+  , storeTCPPort :: Int
   } deriving (Eq, Generic, Ord, Show)
 
-instance HasProtoVersion TestStoreConfig where
+data StoreConnection
-  hasProtoVersion = testStoreConfig_protoVersion
+  = StoreConnection_Socket StoreSocketPath
+  | StoreConnection_TCP StoreTCP
+  deriving (Eq, Generic, Ord, Show)
 
-instance HasStoreDir TestStoreConfig where
+instance Default StoreConnection where
-  hasStoreDir = testStoreConfig_dir
+  def = StoreConnection_Socket def
-
--- | 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
-    }

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
+  getReplyS :: NixSerializer ProtoStoreConfig ReplySError a
-    :: ( HasStoreDir r
-       , HasProtoVersion r
-       )
-    => NixSerializer r ReplySError a
 
 instance StoreReply () where
   getReplyS = opSuccess

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
+  -> CreateProcess
-  -> [String]
   -> 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
+  :: FilePath -- ^ Temporary directory
-  -> IO (ProcessHandle, MonadStore a -> Run IO a)
+  -> 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
+       , StoreConnection_Socket
-          sockFp
+          $ StoreSocketPath sockFp
-          (StoreDir
-            $ Data.ByteString.Char8.pack
-            $ fp </> "store"
-          )
        )
  where
   sockFp = fp </> "var/nix/daemon-socket/socket"
@@ -146,10 +147,10 @@ enterNamespaces = do
     [ GroupMapping 0 gid 1 ]
     True
 
-withNixDaemon
+withNixDaemon'
-  :: ((MonadStore a -> Run IO a) -> IO a)
+  :: (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)
+  :: MonadRemoteStore m
-  -> MonadStore a
+  => (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" $
+makeProtoSpec
-      itRights "syncs with garbage collector" syncWithGC
+  :: (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
+  context "verifyStore" $ do
-      itRights "check=False repair=False" $
+    itRights "check=False repair=False" $
-        verifyStore
+      verifyStore
-          CheckMode_DontCheck
+        CheckMode_DontCheck
-          RepairMode_DontRepair
+        RepairMode_DontRepair
-        `shouldReturn` False
+      `shouldReturn` False
 
-      itRights "check=True repair=False" $
+    itRights "check=True repair=False" $
-        verifyStore
+      verifyStore
-          CheckMode_DoCheck
+        CheckMode_DoCheck
-          RepairMode_DontRepair
+        RepairMode_DontRepair
-        `shouldReturn` False
+      `shouldReturn` False
 
-      --privileged
+    --privileged
-      itRights "check=True repair=True" $
+    itRights "check=True repair=True" $
-        verifyStore
+      verifyStore
-          CheckMode_DoCheck
+        CheckMode_DoCheck
-          RepairMode_DoRepair
+        RepairMode_DoRepair
-        `shouldReturn` False
+      `shouldReturn` False
 
-    context "addTextToStore" $
+  context "addTextToStore" $
-      itRights "adds text to store" $ withPath pure
+    itRights "adds text to store" $ withPath pure
 
-    context "isValidPath" $ do
+  context "isValidPath" $ do
-      itRights "validates path" $ withPath $ \path -> do
+    itRights "validates path" $ withPath $ \path -> do
-        liftIO $ print path
+      isValidPath path `shouldReturn` True
-        isValidPath path `shouldReturn` True
-      itLefts "fails on invalid path"
-        $ System.Nix.Store.Remote.MonadStore.mapStoreConfig
-            (\sc -> sc { storeConfig_dir = StoreDir "/asdf" })
-            $ isValidPath invalidPath
 
-    context "queryAllValidPaths" $ do
+    itLefts "fails on invalid path" $ do
-      itRights "empty query" queryAllValidPaths
+      setStoreDir (StoreDir "/asdf")
-      itRights "non-empty query" $ withPath $ \path ->
+      isValidPath invalidPath
-        queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path]
 
-    context "queryPathInfo" $
+  context "queryAllValidPaths" $ do
-      itRights "queries path info" $ withPath $ \path -> do
+    itRights "empty query" queryAllValidPaths
-        meta <- queryPathInfo path
+    itRights "non-empty query" $ withPath $ \path ->
-        (metadataReferences <$> meta) `shouldBe` (Just mempty)
+      queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path]
 
-    context "ensurePath" $
+  context "queryPathInfo" $
-      itRights "simple ensure" $ withPath ensurePath
+    itRights "queries path info" $ withPath $ \path -> do
+      meta <- queryPathInfo path
+      (metadataReferences <$> meta) `shouldBe` (Just mempty)
 
-    context "addTempRoot" $
+  context "ensurePath" $
-      itRights "simple addition" $ withPath addTempRoot
+    itRights "simple ensure" $ withPath ensurePath
 
-    context "addIndirectRoot" $
+  context "addTempRoot" $
-      itRights "simple addition" $ withPath addIndirectRoot
+    itRights "simple addition" $ withPath addTempRoot
 
-    let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p]
+  context "addIndirectRoot" $
+    itRights "simple addition" $ withPath addIndirectRoot
 
-    context "buildPaths" $ do
+  let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p]
-      itRights "build Normal" $ withPath $ \path -> do
-        buildPaths (toDerivedPathSet path) BuildMode_Normal
 
-      itRights "build Check" $ withPath $ \path -> do
+  context "buildPaths" $ do
-        buildPaths (toDerivedPathSet path) BuildMode_Check
+    itRights "build Normal" $ withPath $ \path -> do
+      buildPaths (toDerivedPathSet path) BuildMode_Normal
 
-      itLefts "build Repair" $ withPath $ \path -> do
+    itRights "build Check" $ withPath $ \path -> do
-        buildPaths (toDerivedPathSet path) BuildMode_Repair
+      buildPaths (toDerivedPathSet path) BuildMode_Check
 
-    context "roots" $ context "findRoots" $ do
+    itLefts "build Repair" $ withPath $ \path -> do
-        itRights "empty roots" (findRoots `shouldReturn` mempty)
+      buildPaths (toDerivedPathSet path) BuildMode_Repair
 
-        itRights "path added as a temp root" $ withPath $ \_ -> do
+  context "roots" $ context "findRoots" $ do
-          roots <- findRoots
+    itRights "empty roots" (findRoots `shouldReturn` mempty)
-          roots `shouldSatisfy` ((== 1) . Data.Map.size)
 
-    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 "indirect root" $ withPath $ \path -> do
-      itRights "queries" $ withPath $ \path -> do
+      let expectRoots =
-        queryMissing (toDerivedPathSet path)
+            if flavor == SpecFlavor_MITM
-        `shouldReturn`
+            then 1 -- nested client closes its connection so temp root gets removed
-        Missing
+            else 2
-          { missingWillBuild = mempty
+      addIndirectRoot path
-          , missingWillSubstitute = mempty
+      roots <- findRoots
-          , missingUnknownPaths = mempty
+      roots `shouldSatisfy` ((== expectRoots) . Data.Map.size)
-          , missingDownloadSize = 0
-          , missingNarSize = 0
-          }
 
-    context "addToStore" $
+  context "optimiseStore" $ itRights "optimises" optimiseStore
-      itRights "adds file to store" $ do
-        fp <-
-          liftIO
-          $ System.IO.Temp.writeSystemTempFile
-              "addition"
-              "yolo"
 
-        addToStore
+  context "queryMissing" $
-          (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition")
+    itRights "queries" $ withPath $ \path -> do
-          (System.Nix.Nar.dumpPath fp)
+      queryMissing (toDerivedPathSet path)
-          FileIngestionMethod_Flat
+      `shouldReturn`
-          (Some HashAlgo_SHA256)
+      Missing
-          RepairMode_DontRepair
+        { missingWillBuild = mempty
+        , missingWillSubstitute = mempty
+        , missingUnknownPaths = mempty
+        , missingDownloadSize = 0
+        , missingNarSize = 0
+        }
 
-    context "with dummy" $ do
+  context "addToStore" $
-      itRights "adds dummy" dummy
+    itRights "adds file to store" $ do
+      fp <-
+        liftIO
+        $ System.IO.Temp.writeSystemTempFile
+            "addition"
+            "yolo"
 
-      itRights "valid dummy" $ do
+      addToStore
-        path <- dummy
+        (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition")
-        isValidPath path `shouldReturn` True
+        (System.Nix.Nar.dumpPath fp)
+        FileIngestionMethod_Flat
+        (Some HashAlgo_SHA256)
+        RepairMode_DontRepair
 
-    context "collectGarbage" $ do
+  context "with dummy" $ do
-      itRights "delete a specific path from the store" $ withPath $ \path -> do
+    itRights "adds dummy" dummy
-          -- clear temp gc roots so the delete works. restarting the nix daemon should also do this...
+
-          storeDir <- getStoreDir
+    itRights "valid dummy" $ do
-          let tempRootsDir = Data.Text.unpack $ mconcat [ Data.Text.Encoding.decodeUtf8 (unStoreDir storeDir), "/../var/nix/temproots/" ]
+      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
-            $ System.Directory.listDirectory
+          forM_ tempRootList $ \entry -> do
-                tempRootsDir
-          liftIO $ 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{..} <-
+        GCResult{..} <-
-            collectGarbage
+          collectGarbage
-              GCOptions
+            GCOptions
-                { gcOptionsOperation = GCAction_DeleteSpecific
+              { gcOptionsOperation = GCAction_DeleteSpecific
-                , gcOptionsIgnoreLiveness = False
+              , gcOptionsIgnoreLiveness = False
-                , gcOptionsPathsToDelete = Data.HashSet.fromList [path]
+              , gcOptionsPathsToDelete = Data.HashSet.fromList [path]
-                , gcOptionsMaxFreed = maxBound
+              , gcOptionsMaxFreed = maxBound
-                }
+              }
-          gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path]
+        gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path]
-          gcResultBytesFreed `shouldBe` 4
+        gcResultBytesFreed `shouldBe` 4

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