From 6b1f0c5309aba0c5d10e73031f208cc654407b86 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 30 Nov 2023 13:50:57 +0100 Subject: [PATCH] remote: heavy lifting Co-Authored-By: Guillaume Maudoux - `RemoteStoreT`, `RemoteStoreState` from #72 Co-Authored-By: John Ericson - Reorg, `MonadRemoteStore0`, `MonadRemoteStoreHandshake`, `PreStoreConfig`, better `greet` Co-Authored-By: Ryan Trinkle - Correctly detect when other side has hung up, throws `RemoteStoreError_Disconnected` --- hnix-store-remote/src/Data/Serializer.hs | 2 +- .../src/System/Nix/Store/Remote.hs | 87 +++++++- .../src/System/Nix/Store/Remote/Logger.hs | 29 ++- .../src/System/Nix/Store/Remote/MonadStore.hs | 187 ++++++++++++++---- .../src/System/Nix/Store/Remote/Protocol.hs | 176 ++++++++--------- .../src/System/Nix/Store/Remote/Socket.hs | 133 +++++++++---- hnix-store-remote/tests-io/NixDaemon.hs | 10 +- 7 files changed, 434 insertions(+), 190 deletions(-) diff --git a/hnix-store-remote/src/Data/Serializer.hs b/hnix-store-remote/src/Data/Serializer.hs index ffd8baa8..d0617437 100644 --- a/hnix-store-remote/src/Data/Serializer.hs +++ b/hnix-store-remote/src/Data/Serializer.hs @@ -193,7 +193,7 @@ tup a b = Serializer data GetSerializerError customGetError = SerializerError_GetFail String | SerializerError_Get customGetError - deriving (Eq, Show) + deriving (Eq, Ord, Show) -- | Helper for transforming nested Eithers -- into @GetSerializerError@ wrapper diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 782448bd..1e47a04b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -3,7 +3,9 @@ {-# LANGUAGE OverloadedStrings #-} module System.Nix.Store.Remote - ( addToStore + ( + -- * Operations + addToStore , addTextToStore , addSignatures , addIndirectRoot @@ -25,51 +27,124 @@ module System.Nix.Store.Remote , queryPathFromHashPart , queryMissing , optimiseStore - , runStore , syncWithGC , verifyStore , module System.Nix.Store.Types , module System.Nix.Store.Remote.MonadStore , module System.Nix.Store.Remote.Types + -- * Compat + , MonadStore + -- * Runners + , runStore + , runStoreOpts + , runStoreOptsTCP ) where import Crypto.Hash (SHA256) import Data.ByteString (ByteString) +import Data.Default.Class (Default(def)) import Data.Dependent.Sum (DSum((:=>))) import Data.HashSet (HashSet) import Data.Map (Map) import Data.Text (Text) import Data.Word (Word64) +import Network.Socket (Family, SockAddr(SockAddrUnix)) import System.Nix.Nar (NarSource) import System.Nix.Derivation (Derivation) import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) import System.Nix.Build (BuildMode, BuildResult) import System.Nix.Hash (NamedAlgo(..), BaseEncoding(Base16), decodeDigestWith) -import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart, InvalidPathError) +import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart, InvalidPathError) import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) import qualified Data.Text +import qualified Control.Exception import qualified Control.Monad import qualified Data.Attoparsec.Text import qualified Data.Text.Encoding import qualified Data.Map.Strict import qualified Data.Serialize.Put import qualified Data.Set +import qualified Network.Socket import qualified System.Nix.ContentAddress import qualified System.Nix.Hash import qualified System.Nix.Signature import qualified System.Nix.StorePath -import System.Nix.Store.Remote.MonadStore -import System.Nix.Store.Remote.Protocol +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed)) +import System.Nix.Store.Remote.Protocol (Run, runStoreSocket, runOp, runOpArgs, runOpArgsIO, simpleOp, simpleOpArgs) import System.Nix.Store.Remote.Socket import System.Nix.Store.Remote.Types import Data.Serialize (get) -import System.Nix.Store.Remote.Serialize +import System.Nix.Store.Remote.Serialize (putDerivation) import System.Nix.Store.Remote.Serialize.Prim +-- * Compat + +type MonadStore = MonadRemoteStore + +-- * Runners + +runStore :: MonadStore a -> Run a +runStore = runStoreOpts defaultSockPath def + where + defaultSockPath :: String + defaultSockPath = "/nix/var/nix/daemon-socket/socket" + +runStoreOpts + :: FilePath + -> StoreDir + -> MonadStore a + -> Run a +runStoreOpts socketPath = + runStoreOpts' + Network.Socket.AF_UNIX + (SockAddrUnix socketPath) + +runStoreOptsTCP + :: String + -> Int + -> StoreDir + -> MonadStore a + -> Run 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, []) + +runStoreOpts' + :: Family + -> SockAddr + -> StoreDir + -> MonadStore a + -> Run a +runStoreOpts' sockFamily sockAddr storeRootDir code = + Control.Exception.bracket + open + (Network.Socket.close . hasStoreSocket) + (flip runStoreSocket code) + where + open = do + soc <- Network.Socket.socket sockFamily Network.Socket.Stream 0 + Network.Socket.connect soc sockAddr + pure PreStoreConfig + { preStoreConfig_socket = soc + , preStoreConfig_dir = storeRootDir + } + +-- * Operations + -- | Pack `Nar` and add it to the store. addToStore :: forall a diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs index d2e5ffe0..7daee301 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -8,18 +8,22 @@ import Data.Serialize (Result(..)) import System.Nix.Store.Remote.Serialize.Prim (putByteString) import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT) import System.Nix.Store.Remote.Socket (sockGet8, sockPut) -import System.Nix.Store.Remote.MonadStore (MonadStore, clearData) -import System.Nix.Store.Remote.Types (Logger(..), ProtoVersion, hasProtoVersion) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore0, RemoteStoreError(..), clearData, getData, getProtoVersion) +import System.Nix.Store.Remote.Types.Logger (Logger(..)) +import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) +import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..)) import qualified Control.Monad -import qualified Control.Monad.Reader -import qualified Control.Monad.State.Strict import qualified Data.Serialize.Get import qualified Data.Serializer -processOutput :: MonadStore [Logger] +processOutput + :: ( HasProtoVersion r + , HasStoreSocket r + ) + => MonadRemoteStore0 r [Logger] processOutput = do - protoVersion <- Control.Monad.Reader.asks hasProtoVersion + protoVersion <- getProtoVersion sockGet8 >>= go . (decoder protoVersion) where decoder @@ -30,14 +34,19 @@ processOutput = do Data.Serialize.Get.runGetPartial (runSerialT protoVersion $ Data.Serializer.getS logger) - go :: Result (Either LoggerSError Logger) -> MonadStore [Logger] + go + :: ( HasProtoVersion r + , HasStoreSocket r + ) + => Result (Either LoggerSError Logger) + -> MonadRemoteStore0 r [Logger] go (Done ectrl leftover) = do Control.Monad.unless (leftover == mempty) $ -- TODO: throwError error $ "Leftovers detected: '" ++ show leftover ++ "'" - protoVersion <- Control.Monad.Reader.asks hasProtoVersion + protoVersion <- getProtoVersion case ectrl of -- TODO: tie this with throwError and better error type Left e -> error $ show e @@ -46,9 +55,9 @@ processOutput = do e@(Logger_Error _) -> pure [e] Logger_Last -> pure [Logger_Last] Logger_Read _n -> do - (mdata, _) <- Control.Monad.State.Strict.get + mdata <- getData case mdata of - Nothing -> throwError "No data to read provided" + Nothing -> throwError RemoteStoreError_NoDataProvided Just part -> do -- XXX: we should check/assert part size against n of (Read n) sockPut $ putByteString part diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs index a2f54280..3ff17d7d 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -1,58 +1,171 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module System.Nix.Store.Remote.MonadStore - ( MonadStore - , mapStoreDir + ( RemoteStoreState(..) + , RemoteStoreError(..) + , WorkerError(..) + , RemoteStoreT + , runRemoteStoreT + , mapStoreConfig + , MonadRemoteStore0 + , MonadRemoteStore + , MonadRemoteStoreHandshake + -- * , getStoreDir - , getLog - , flushLog + , getStoreSocket + , getProtoVersion + -- * + , appendLogs + , getLogs + , flushLogs , gotError , getErrors + -- * + , getData , setData , clearData ) where -import Control.Monad.Except (ExceptT) -import Control.Monad.Reader (ReaderT, asks) -import Control.Monad.Reader.Class (MonadReader) -import Control.Monad.State.Strict (StateT, gets, modify) -import Data.ByteString (ByteString) - -import Control.Monad.Trans.State.Strict (mapStateT) -import Control.Monad.Trans.Except (mapExceptT) -import Control.Monad.Trans.Reader (withReaderT) +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.State.Strict (get, 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 Data.ByteString (ByteString) +import Data.Word (Word64) +import Network.Socket (Socket) import System.Nix.StorePath (HasStoreDir(..), StoreDir) +import System.Nix.Store.Remote.Serializer (SError) import System.Nix.Store.Remote.Types.Logger (Logger, isError) -import System.Nix.Store.Remote.Types.StoreConfig (StoreConfig(..)) +import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) +import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), PreStoreConfig, StoreConfig) + +data RemoteStoreState = RemoteStoreState { + remoteStoreState_logs :: [Logger] + , remoteStoreState_mData :: Maybe ByteString + } deriving (Eq, Ord, Show) + +data RemoteStoreError + = RemoteStoreError_Fixme String + | RemoteStoreError_BuildFailed + | RemoteStoreError_ClientVersionTooOld + | RemoteStoreError_Disconnected + | RemoteStoreError_GetAddrInfoFailed + | RemoteStoreError_SerializerGet SError + | RemoteStoreError_SerializerPut SError + | RemoteStoreError_NoDataProvided + | RemoteStoreError_ProtocolMismatch + | RemoteStoreError_WorkerMagic2Mismatch + | RemoteStoreError_WorkerError WorkerError + deriving (Eq, Show, Ord) + +-- | Non-fatal (to server) errors in worker interaction +data WorkerError + = WorkerError_SendClosed + | WorkerError_InvalidOperation Word64 + | WorkerError_NotYetImplemented + deriving (Eq, Ord, Show) + +newtype RemoteStoreT r m a = RemoteStoreT + { _unRemoteStoreT + :: ExceptT RemoteStoreError + (StateT RemoteStoreState + (ReaderT r m)) a + } + deriving + ( Functor + , Applicative + , Monad + , MonadReader r + --, MonadState StoreState -- Avoid making the internal state explicit + --, MonadFail + , MonadError RemoteStoreError + , MonadIO + ) + +instance MonadTrans (RemoteStoreT r) where + lift = RemoteStoreT . lift . lift . lift + +-- | Runner for @RemoteStoreT@ +runRemoteStoreT + :: ( HasStoreDir r + , HasStoreSocket r + , Monad m + ) + => r + -> RemoteStoreT r m a + -> m (Either RemoteStoreError a, [Logger]) +runRemoteStoreT r = + fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreState_logs)) + . (`runReaderT` r) + . (`runStateT` emptyState) + . runExceptT + . _unRemoteStoreT + where + emptyState = RemoteStoreState + { remoteStoreState_logs = mempty + , remoteStoreState_mData = Nothing + } + +type MonadRemoteStore0 r = RemoteStoreT r IO + +type MonadRemoteStore = MonadRemoteStore0 StoreConfig + +type MonadRemoteStoreHandshake = MonadRemoteStore0 PreStoreConfig + +mapStoreConfig + :: (rb -> ra) + -> (MonadRemoteStore0 ra a -> MonadRemoteStore0 rb a) +mapStoreConfig f = + RemoteStoreT + . ( mapExceptT + . mapStateT + . withReaderT + ) f + . _unRemoteStoreT + +-- | Ask for a @StoreDir@ +getStoreDir :: HasStoreDir r => MonadRemoteStore0 r StoreDir +getStoreDir = hasStoreDir <$> RemoteStoreT ask + +-- | Ask for a @StoreDir@ +getStoreSocket :: HasStoreSocket r => MonadRemoteStore0 r Socket +getStoreSocket = hasStoreSocket <$> RemoteStoreT ask -- | Ask for a @StoreDir@ -getStoreDir :: (HasStoreDir r, MonadReader r m) => m StoreDir -getStoreDir = asks hasStoreDir +getProtoVersion :: HasProtoVersion r => MonadRemoteStore0 r ProtoVersion +getProtoVersion = hasProtoVersion <$> RemoteStoreT ask + +gotError :: MonadRemoteStore0 r Bool +gotError = any isError <$> getLogs + +getErrors :: MonadRemoteStore0 r [Logger] +getErrors = filter isError <$> getLogs -type MonadStore a - = ExceptT - String - (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO)) - a +-- * --- | For lying about the store dir in tests -mapStoreDir :: (StoreDir -> StoreDir) -> (MonadStore a -> MonadStore a) -mapStoreDir f = mapExceptT . mapStateT . withReaderT - $ \c@StoreConfig { storeConfig_dir = sd } -> c { storeConfig_dir = f sd } +appendLogs :: [Logger] -> MonadRemoteStore0 r () +appendLogs x = RemoteStoreT + $ modify + $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s <> x } -gotError :: MonadStore Bool -gotError = gets (any isError . snd) +getLogs :: MonadRemoteStore0 r [Logger] +getLogs = remoteStoreState_logs <$> RemoteStoreT get -getErrors :: MonadStore [Logger] -getErrors = gets (filter isError . snd) +flushLogs :: MonadRemoteStore0 r () +flushLogs = RemoteStoreT $ modify $ \s -> s { remoteStoreState_logs = mempty } -getLog :: MonadStore [Logger] -getLog = gets snd +-- * -flushLog :: MonadStore () -flushLog = modify (\(a, _b) -> (a, [])) +getData :: MonadRemoteStore0 r (Maybe ByteString) +getData = remoteStoreState_mData <$> RemoteStoreT get -setData :: ByteString -> MonadStore () -setData x = modify (\(_, b) -> (Just x, b)) +setData :: ByteString -> MonadRemoteStore0 r () +setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x } -clearData :: MonadStore () -clearData = modify (\(_, b) -> (Nothing, b)) +clearData :: MonadRemoteStore0 r () +clearData = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = Nothing } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs index e830c4a8..ff5bd8c0 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs @@ -1,42 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} module System.Nix.Store.Remote.Protocol - ( WorkerOp(..) + ( Run , simpleOp , simpleOpArgs , runOp , runOpArgs , runOpArgsIO - , runStore - , runStoreOpts - , runStoreOptsTCP - , runStoreOpts' + , runStoreSocket , ourProtoVersion - , GCAction(..) ) where -import qualified Control.Monad -import Control.Exception ( bracket ) -import Control.Monad.Except -import Control.Monad.Reader (asks, runReaderT) -import Control.Monad.State.Strict +import Control.Monad (unless, when) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Data.Serialize.Put (Put, runPut) -import Data.Default.Class (Default(def)) import qualified Data.Bool -import Data.Serialize.Get -import Data.Serialize.Put import qualified Data.ByteString +import qualified Network.Socket.ByteString -import Network.Socket (SockAddr(SockAddrUnix)) -import qualified Network.Socket as S -import Network.Socket.ByteString (recv, sendAll) - -import System.Nix.StorePath (StoreDir(..)) -import System.Nix.Store.Remote.Serialize.Prim -import System.Nix.Store.Remote.Logger +import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore -import System.Nix.Store.Remote.Socket -import System.Nix.Store.Remote.Serializer (protoVersion) +import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) +import System.Nix.Store.Remote.Serializer (bool, enum, int, protoVersion, text) import System.Nix.Store.Remote.Types ourProtoVersion :: ProtoVersion @@ -50,28 +37,27 @@ workerMagic1 = 0x6e697863 workerMagic2 :: Int workerMagic2 = 0x6478696f -defaultSockPath :: String -defaultSockPath = "/nix/var/nix/daemon-socket/socket" +type Run a = IO (Either RemoteStoreError a, [Logger]) -simpleOp :: WorkerOp -> MonadStore Bool +simpleOp :: WorkerOp -> MonadRemoteStore Bool simpleOp op = simpleOpArgs op $ pure () -simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool +simpleOpArgs :: WorkerOp -> Put -> MonadRemoteStore Bool simpleOpArgs op args = do runOpArgs op args err <- gotError Data.Bool.bool - sockGetBool + (sockGetS bool) (do -- TODO: don't use show - getErrors >>= throwError . show + getErrors >>= throwError . RemoteStoreError_Fixme . show ) err -runOp :: WorkerOp -> MonadStore () +runOp :: WorkerOp -> MonadRemoteStore () runOp op = runOpArgs op $ pure () -runOpArgs :: WorkerOp -> Put -> MonadStore () +runOpArgs :: WorkerOp -> Put -> MonadRemoteStore () runOpArgs op args = runOpArgsIO op @@ -79,76 +65,70 @@ runOpArgs op args = runOpArgsIO :: WorkerOp - -> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ()) - -> MonadStore () + -> ((Data.ByteString.ByteString -> MonadRemoteStore ()) + -> MonadRemoteStore () + ) + -> MonadRemoteStore () runOpArgsIO op encoder = do + sockPutS enum op - sockPut $ putEnum op - - soc <- asks storeConfig_socket - encoder (liftIO . sendAll soc) + soc <- getStoreSocket + encoder (liftIO . Network.Socket.ByteString.sendAll soc) out <- processOutput - modify (\(a, b) -> (a, b <> out)) + appendLogs out err <- gotError - Control.Monad.when err $ do + when err $ do -- TODO: don't use show - getErrors >>= throwError . show - -runStore :: MonadStore a -> IO (Either String a, [Logger]) -runStore = runStoreOpts defaultSockPath def - -runStoreOpts - :: FilePath -> StoreDir -> MonadStore a -> IO (Either String a, [Logger]) -runStoreOpts path = runStoreOpts' S.AF_UNIX (SockAddrUnix path) - -runStoreOptsTCP - :: String -> Int -> StoreDir -> MonadStore a -> IO (Either String a, [Logger]) -runStoreOptsTCP host port storeRootDir code = do - S.getAddrInfo (Just S.defaultHints) (Just host) (Just $ show port) >>= \case - (sockAddr:_) -> runStoreOpts' (S.addrFamily sockAddr) (S.addrAddress sockAddr) storeRootDir code - _ -> pure (Left "Couldn't resolve host and port with getAddrInfo.", []) - -runStoreOpts' - :: S.Family -> S.SockAddr -> StoreDir -> MonadStore a -> IO (Either String a, [Logger]) -runStoreOpts' sockFamily sockAddr storeRootDir code = - bracket open (S.close . storeConfig_socket) run - - where - open = do - soc <- S.socket sockFamily S.Stream 0 - S.connect soc sockAddr - pure StoreConfig - { storeConfig_dir = storeRootDir - , storeConfig_protoVersion = ourProtoVersion - , storeConfig_socket = soc - } - - greet = do - sockPut $ putInt workerMagic1 - soc <- asks hasStoreSocket - vermagic <- liftIO $ recv soc 16 - let - eres = - flip runGet vermagic - $ (,) - <$> (getInt :: Get Int) - <*> (getInt :: Get Int) - - case eres of - Left err -> error $ "Error parsing vermagic " ++ err - Right (magic2, _daemonProtoVersion) -> do - Control.Monad.unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch" - - pv <- asks hasProtoVersion - sockPutS @() protoVersion pv -- clientVersion - sockPut $ putInt (0 :: Int) -- affinity - sockPut $ putInt (0 :: Int) -- obsolete reserveSpace - - processOutput - - run sock = - fmap (\(res, (_data, logs)) -> (res, logs)) - $ (`runReaderT` sock) - $ (`runStateT` (Nothing, [])) - $ runExceptT (greet >> code) + getErrors >>= throwError . RemoteStoreError_Fixme . show + +runStoreSocket + :: PreStoreConfig + -> MonadRemoteStore a + -> Run a +runStoreSocket preStoreConfig code = + runRemoteStoreT preStoreConfig $ do + pv <- greet + mapStoreConfig + (\(PreStoreConfig a b) -> StoreConfig a pv b) + code + + where + greet :: MonadRemoteStoreHandshake ProtoVersion + greet = do + sockPutS int workerMagic1 + + magic <- sockGetS int + unless + (magic == workerMagic2) + $ throwError RemoteStoreError_WorkerMagic2Mismatch + + daemonVersion <- sockGetS protoVersion + + when (daemonVersion < ProtoVersion 1 10) + $ throwError RemoteStoreError_ClientVersionTooOld + + sockPutS protoVersion ourProtoVersion + + when (daemonVersion >= ProtoVersion 1 14) + $ sockPutS int (0 :: Int) -- affinity, obsolete + + when (daemonVersion >= ProtoVersion 1 11) $ do + sockPutS bool False -- reserveSpace, obsolete + + -- not quite right, should be min of the two + -- as well as two ^ above + when (ourProtoVersion >= ProtoVersion 1 33) $ do + -- If we were buffering I/O, we would flush the output here. + _daemonNixVersion <- sockGetS text + return () + + -- TODO do something with it + -- TODO patter match better + _ <- mapStoreConfig + (\(PreStoreConfig a b) -> StoreConfig a ourProtoVersion b) + processOutput + + -- TODO should be minimum of + -- ourProtoVersion vs daemonVersion + pure ourProtoVersion diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs index 9ef0435e..ad806a7f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -1,19 +1,21 @@ module System.Nix.Store.Remote.Socket where -import Control.Monad.Except (throwError) -import Control.Monad.Reader (asks) +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.HashSet (HashSet) import Data.Serialize.Get (Get, Result(..)) -import Data.Serialize.Put +import Data.Serialize.Put (Put, runPut) import Network.Socket.ByteString (recv, sendAll) -import System.Nix.StorePath (StorePath) -import System.Nix.Store.Remote.MonadStore -import System.Nix.Store.Remote.Serializer (NixSerializer, runP) -import System.Nix.Store.Remote.Serialize.Prim -import System.Nix.Store.Remote.Types +import System.Nix.StorePath (HasStoreDir, StorePath) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore0, RemoteStoreError(..), getStoreDir, getStoreSocket) +import System.Nix.Store.Remote.Serializer (NixSerializer, SError, runP, runSerialT) +import System.Nix.Store.Remote.Serialize.Prim (getInt, getByteString, getByteStrings, getPath, getPathsOrFail) +import System.Nix.Store.Remote.Types (HasStoreSocket(..)) +import qualified Data.ByteString +import qualified Data.Serializer import qualified Data.Serialize.Get genericIncremental @@ -31,57 +33,116 @@ genericIncremental getsome parser = do go (k chunk) go (Fail msg _leftover) = error msg -getSocketIncremental :: Get a -> MonadStore a -getSocketIncremental = genericIncremental sockGet8 - -sockGet8 :: MonadStore ByteString +sockGet8 + :: HasStoreSocket r + => MonadRemoteStore0 r ByteString sockGet8 = do - soc <- asks hasStoreSocket + soc <- getStoreSocket liftIO $ recv soc 8 -sockPut :: Put -> MonadStore () +sockPut + :: HasStoreSocket r + => Put + -> MonadRemoteStore0 r () sockPut p = do - soc <- asks hasStoreSocket + soc <- getStoreSocket liftIO $ sendAll soc $ runPut p sockPutS - :: Show e - => NixSerializer ProtoVersion e a + :: ( MonadReader r m + , MonadError RemoteStoreError m + , MonadIO m + , HasStoreSocket r + ) + => NixSerializer r SError a -> a - -> MonadStore () + -> m () sockPutS s a = do - soc <- asks hasStoreSocket - pv <- asks hasProtoVersion - case runP s pv a of - Right x -> liftIO $ sendAll soc x - -- TODO: errors - Left e -> throwError $ show e - -sockGet :: Get a -> MonadStore a + r <- ask + case runP s r a of + Right x -> liftIO $ sendAll (hasStoreSocket r) x + Left e -> throwError $ RemoteStoreError_SerializerPut e + +sockGetS + :: forall r m a + . ( HasStoreSocket r + , MonadError RemoteStoreError m + , MonadReader r m + , MonadIO m + ) + => NixSerializer r SError a + -> m a +sockGetS s = do + r <- ask + res <- genericIncremental sockGet8' + $ runSerialT r $ Data.Serializer.getS s + + case res of + Right x -> pure x + Left e -> throwError $ RemoteStoreError_SerializerGet e + where + sockGet8' :: MonadError RemoteStoreError m => m ByteString + sockGet8' = do + soc <- asks hasStoreSocket + result <- liftIO $ recv soc 8 + if Data.ByteString.length result == 0 + then throwError RemoteStoreError_Disconnected + else pure result + +-- * Obsolete + +getSocketIncremental + :: HasStoreSocket r + => Get a + -> MonadRemoteStore0 r a +getSocketIncremental = genericIncremental sockGet8 + +sockGet + :: HasStoreSocket r + => Get a + -> MonadRemoteStore0 r a sockGet = getSocketIncremental -sockGetInt :: Integral a => MonadStore a +sockGetInt + :: ( HasStoreSocket r + , Integral a + ) + => MonadRemoteStore0 r a sockGetInt = getSocketIncremental getInt -sockGetBool :: MonadStore Bool +sockGetBool + :: HasStoreSocket r + => MonadRemoteStore0 r Bool sockGetBool = (== (1 :: Int)) <$> sockGetInt -sockGetStr :: MonadStore ByteString +sockGetStr + :: HasStoreSocket r + => MonadRemoteStore0 r ByteString sockGetStr = getSocketIncremental getByteString -sockGetStrings :: MonadStore [ByteString] +sockGetStrings + :: HasStoreSocket r + => MonadRemoteStore0 r [ByteString] sockGetStrings = getSocketIncremental getByteStrings -sockGetPath :: MonadStore StorePath +sockGetPath + :: ( HasStoreDir r + , HasStoreSocket r + ) + => MonadRemoteStore0 r StorePath sockGetPath = do sd <- getStoreDir pth <- getSocketIncremental (getPath sd) either - (throwError . show) + (throwError . RemoteStoreError_Fixme . show) pure pth -sockGetPathMay :: MonadStore (Maybe StorePath) +sockGetPathMay + :: ( HasStoreDir r + , HasStoreSocket r + ) + => MonadRemoteStore0 r (Maybe StorePath) sockGetPathMay = do sd <- getStoreDir pth <- getSocketIncremental (getPath sd) @@ -91,7 +152,11 @@ sockGetPathMay = do Just pth -sockGetPaths :: MonadStore (HashSet StorePath) +sockGetPaths + :: ( HasStoreDir r + , HasStoreSocket r + ) + => MonadRemoteStore0 r (HashSet StorePath) sockGetPaths = do sd <- getStoreDir getSocketIncremental (getPathsOrFail sd) diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index b7f34120..a2d4087a 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemon.hs @@ -29,7 +29,6 @@ import System.Nix.Build import System.Nix.StorePath import System.Nix.StorePath.Metadata import System.Nix.Store.Remote -import System.Nix.Store.Remote.Protocol import Crypto.Hash (SHA256) import System.Nix.Nar (dumpPath) @@ -89,7 +88,7 @@ error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e561612 startDaemon :: FilePath - -> IO (P.ProcessHandle, MonadStore a -> IO (Either String a, [Logger])) + -> IO (P.ProcessHandle, MonadStore a -> IO (Either RemoteStoreError a, [Logger])) startDaemon fp = do writeConf (fp "etc" "nix.conf") p <- createProcessEnv fp "nix-daemon" [] @@ -110,7 +109,7 @@ enterNamespaces = do writeGroupMappings Nothing [GroupMapping 0 gid 1] True withNixDaemon - :: ((MonadStore a -> IO (Either String a, [Logger])) -> IO a) -> IO a + :: ((MonadStore a -> IO (Either RemoteStoreError a, [Logger])) -> IO a) -> IO a withNixDaemon action = withSystemTempDirectory "test-nix-store" $ \path -> do @@ -213,7 +212,10 @@ spec_protocol = Hspec.around withNixDaemon $ itRights "validates path" $ withPath $ \path -> do liftIO $ print path isValidPathUncached path `shouldReturn` True - itLefts "fails on invalid path" $ mapStoreDir (\_ -> StoreDir "/asdf") $ isValidPathUncached invalidPath + itLefts "fails on invalid path" + $ mapStoreConfig + (\sc -> sc { storeConfig_dir = StoreDir "/asdf" }) + $ isValidPathUncached invalidPath context "queryAllValidPaths" $ do itRights "empty query" queryAllValidPaths