From a3c9530198995e3939643d8bb4192c6cadf58692 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 30 Nov 2023 13:50:57 +0100 Subject: [PATCH 001/104] remote: heavy lifting - By layus - `RemoteStoreT`, `RemoteStoreState` from #72 - By Ericson2314 - Reorg, `MonadRemoteStore0`, `MonadRemoteStoreHandshake`, `PreStoreConfig`, better `greet` - By ryantrinkle - Correctly detect when other side has hung up, throws `RemoteStoreError_Disconnected` Co-Authored-By: Guillaume Maudoux Co-Authored-By: John Ericson Co-Authored-By: Ryan Trinkle --- 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 | 156 +++++++-------- .../src/System/Nix/Store/Remote/Socket.hs | 131 ++++++++---- hnix-store-remote/tests-io/NixDaemon.hs | 10 +- 7 files changed, 423 insertions(+), 179 deletions(-) diff --git a/hnix-store-remote/src/Data/Serializer.hs b/hnix-store-remote/src/Data/Serializer.hs index ffd8baa..d061743 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 782448b..1e47a04 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 d2e5ffe..7daee30 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 a2f5428..3ff17d7 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 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 Control.Monad.Trans.State.Strict (mapStateT) -import Control.Monad.Trans.Except (mapExceptT) -import Control.Monad.Trans.Reader (withReaderT) - +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, MonadReader r m) => m StoreDir -getStoreDir = asks hasStoreDir +getStoreDir :: HasStoreDir r => MonadRemoteStore0 r StoreDir +getStoreDir = hasStoreDir <$> RemoteStoreT ask -type MonadStore a - = ExceptT - String - (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO)) - a +-- | Ask for a @StoreDir@ +getStoreSocket :: HasStoreSocket r => MonadRemoteStore0 r Socket +getStoreSocket = hasStoreSocket <$> RemoteStoreT ask --- | 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 } +-- | Ask for a @StoreDir@ +getProtoVersion :: HasProtoVersion r => MonadRemoteStore0 r ProtoVersion +getProtoVersion = hasProtoVersion <$> RemoteStoreT ask -gotError :: MonadStore Bool -gotError = gets (any isError . snd) +gotError :: MonadRemoteStore0 r Bool +gotError = any isError <$> getLogs -getErrors :: MonadStore [Logger] -getErrors = gets (filter isError . snd) +getErrors :: MonadRemoteStore0 r [Logger] +getErrors = filter isError <$> getLogs -getLog :: MonadStore [Logger] -getLog = gets snd +-- * -flushLog :: MonadStore () -flushLog = modify (\(a, _b) -> (a, [])) +appendLogs :: [Logger] -> MonadRemoteStore0 r () +appendLogs x = RemoteStoreT + $ modify + $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s <> x } -setData :: ByteString -> MonadStore () -setData x = modify (\(_, b) -> (Just x, b)) +getLogs :: MonadRemoteStore0 r [Logger] +getLogs = remoteStoreState_logs <$> RemoteStoreT get -clearData :: MonadStore () -clearData = modify (\(_, b) -> (Nothing, b)) +flushLogs :: MonadRemoteStore0 r () +flushLogs = RemoteStoreT $ modify $ \s -> s { remoteStoreState_logs = mempty } + +-- * + +getData :: MonadRemoteStore0 r (Maybe ByteString) +getData = remoteStoreState_mData <$> RemoteStoreT get + +setData :: ByteString -> MonadRemoteStore0 r () +setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x } + +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 e830c4a..ff5bd8c 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 + getErrors >>= throwError . RemoteStoreError_Fixme . show -runStore :: MonadStore a -> IO (Either String a, [Logger]) -runStore = runStoreOpts defaultSockPath def +runStoreSocket + :: PreStoreConfig + -> MonadRemoteStore a + -> Run a +runStoreSocket preStoreConfig code = + runRemoteStoreT preStoreConfig $ do + pv <- greet + mapStoreConfig + (\(PreStoreConfig a b) -> StoreConfig a pv b) + code -runStoreOpts - :: FilePath -> StoreDir -> MonadStore a -> IO (Either String a, [Logger]) -runStoreOpts path = runStoreOpts' S.AF_UNIX (SockAddrUnix path) + where + greet :: MonadRemoteStoreHandshake ProtoVersion + greet = do + sockPutS int workerMagic1 -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.", []) + magic <- sockGetS int + unless + (magic == workerMagic2) + $ throwError RemoteStoreError_WorkerMagic2Mismatch -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 + daemonVersion <- sockGetS protoVersion - 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 - } + when (daemonVersion < ProtoVersion 1 10) + $ throwError RemoteStoreError_ClientVersionTooOld - greet = do - sockPut $ putInt workerMagic1 - soc <- asks hasStoreSocket - vermagic <- liftIO $ recv soc 16 - let - eres = - flip runGet vermagic - $ (,) - <$> (getInt :: Get Int) - <*> (getInt :: Get Int) + sockPutS protoVersion ourProtoVersion - case eres of - Left err -> error $ "Error parsing vermagic " ++ err - Right (magic2, _daemonProtoVersion) -> do - Control.Monad.unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch" + when (daemonVersion >= ProtoVersion 1 14) + $ sockPutS int (0 :: Int) -- affinity, obsolete - pv <- asks hasProtoVersion - sockPutS @() protoVersion pv -- clientVersion - sockPut $ putInt (0 :: Int) -- affinity - sockPut $ putInt (0 :: Int) -- obsolete reserveSpace + when (daemonVersion >= ProtoVersion 1 11) $ do + sockPutS bool False -- reserveSpace, obsolete - processOutput + -- 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 () - run sock = - fmap (\(res, (_data, logs)) -> (res, logs)) - $ (`runReaderT` sock) - $ (`runStateT` (Nothing, [])) - $ runExceptT (greet >> code) + -- 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 9ef0435..ad806a7 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 + r <- ask + case runP s r a of + Right x -> liftIO $ sendAll (hasStoreSocket r) x + Left e -> throwError $ RemoteStoreError_SerializerPut e -sockGet :: Get a -> MonadStore a +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 b7f3412..a2d4087 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 From e700c7255c3ef3e07fad3857ff771ca5e11fafdf Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 30 Nov 2023 14:43:04 +0100 Subject: [PATCH 002/104] remote: Remote.Protocol -> Remote.Client --- hnix-store-remote/hnix-store-remote.cabal | 2 +- hnix-store-remote/src/System/Nix/Store/Remote.hs | 2 +- .../src/System/Nix/Store/Remote/{Protocol.hs => Client.hs} | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) rename hnix-store-remote/src/System/Nix/Store/Remote/{Protocol.hs => Client.hs} (98%) diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index e6d5029..6a1aaf7 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -75,9 +75,9 @@ library , Data.Serializer.Example , System.Nix.Store.Remote , System.Nix.Store.Remote.Arbitrary + , System.Nix.Store.Remote.Client , System.Nix.Store.Remote.Logger , System.Nix.Store.Remote.MonadStore - , System.Nix.Store.Remote.Protocol , System.Nix.Store.Remote.Serialize , System.Nix.Store.Remote.Serialize.Prim , System.Nix.Store.Remote.Serializer diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 1e47a04..b51ce2b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -73,7 +73,7 @@ import qualified System.Nix.Signature import qualified System.Nix.StorePath 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.Client (Run, runStoreSocket, runOp, runOpArgs, runOpArgsIO, simpleOp, simpleOpArgs) import System.Nix.Store.Remote.Socket import System.Nix.Store.Remote.Types diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs similarity index 98% rename from hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs rename to hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index ff5bd8c..c50856d 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module System.Nix.Store.Remote.Protocol +module System.Nix.Store.Remote.Client ( Run , simpleOp , simpleOpArgs From 3e135c11051f8ebec9b7ff9903422f4beaf0b99e Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 30 Nov 2023 14:45:38 +0100 Subject: [PATCH 003/104] remote: neaten MonadStore --- .../src/System/Nix/Store/Remote/MonadStore.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) 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 3ff17d7..94f19c3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -10,23 +10,22 @@ module System.Nix.Store.Remote.MonadStore , MonadRemoteStore0 , MonadRemoteStore , MonadRemoteStoreHandshake - -- * + -- * Reader helpers , getStoreDir , getStoreSocket , getProtoVersion - -- * + -- * Logs , appendLogs , getLogs , flushLogs , gotError , getErrors - -- * + -- * Data required from client , getData , setData , clearData ) where - import Control.Monad.Except (MonadError) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (MonadReader, ask) @@ -81,8 +80,7 @@ newtype RemoteStoreT r m a = RemoteStoreT , Applicative , Monad , MonadReader r - --, MonadState StoreState -- Avoid making the internal state explicit - --, MonadFail + --, MonadState StoreState -- Avoid making the internal state explicit , MonadError RemoteStoreError , MonadIO ) @@ -140,14 +138,14 @@ getStoreSocket = hasStoreSocket <$> RemoteStoreT ask getProtoVersion :: HasProtoVersion r => MonadRemoteStore0 r ProtoVersion getProtoVersion = hasProtoVersion <$> RemoteStoreT ask +-- * Logs + gotError :: MonadRemoteStore0 r Bool gotError = any isError <$> getLogs getErrors :: MonadRemoteStore0 r [Logger] getErrors = filter isError <$> getLogs --- * - appendLogs :: [Logger] -> MonadRemoteStore0 r () appendLogs x = RemoteStoreT $ modify @@ -159,7 +157,7 @@ getLogs = remoteStoreState_logs <$> RemoteStoreT get flushLogs :: MonadRemoteStore0 r () flushLogs = RemoteStoreT $ modify $ \s -> s { remoteStoreState_logs = mempty } --- * +-- * Data required from client getData :: MonadRemoteStore0 r (Maybe ByteString) getData = remoteStoreState_mData <$> RemoteStoreT get From aaf05675542bd43c72752b28086467c073754f00 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 30 Nov 2023 14:58:35 +0100 Subject: [PATCH 004/104] remote: add Remote.GADT Closes #149 Co-Authored-By: John Ericson --- hnix-store-remote/hnix-store-remote.cabal | 1 + .../src/System/Nix/Store/Remote/GADT.hs | 150 ++++++++++++++++++ 2 files changed, 151 insertions(+) create mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 6a1aaf7..3f0c18f 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -76,6 +76,7 @@ library , System.Nix.Store.Remote , System.Nix.Store.Remote.Arbitrary , System.Nix.Store.Remote.Client + , System.Nix.Store.Remote.GADT , System.Nix.Store.Remote.Logger , System.Nix.Store.Remote.MonadStore , System.Nix.Store.Remote.Serialize diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs b/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs new file mode 100644 index 0000000..867e64d --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs @@ -0,0 +1,150 @@ +{-# language GADTs #-} +{-# language Rank2Types #-} + +module System.Nix.Store.Remote.GADT + ( StoreRequest(..) + ) where + +import Control.Monad.IO.Class (MonadIO) +import Data.ByteString (ByteString) +import Data.HashSet (HashSet) +import Data.Kind (Type) +import Data.Map (Map) +import Data.Set (Set) +import Data.Text (Text) +import Data.Some (Some) + +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) +import System.Nix.Store.Types (RepairMode) +import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) +import System.Nix.StorePath.Metadata (Metadata) +import System.Nix.Store.Remote.Types.CheckMode (CheckMode) +import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode) + +data StoreRequest :: Type -> Type where + -- | Add @NarSource@ to the store. + AddToStore + :: StorePathName -- ^ Name part of the newly created @StorePath@ + -> Bool -- ^ Add target directory recursively + -> Some HashAlgo + -> (forall m . MonadIO m => NarSource m) -- ^ provide nar stream + -> RepairMode -- ^ Only used by local store backend + -> StoreRequest StorePath + + -- | Add text to store. + -- + -- Reference accepts repair but only uses it + -- to throw error in case of remote talking to nix-daemon. + AddTextToStore + :: Text -- ^ Name of the text + -> Text -- ^ Actual text to add + -> HashSet StorePath -- ^ Set of @StorePath@s that the added text references + -> RepairMode -- ^ Repair mode, must be @RepairMode_DontRepair@ in case of remote backend + -> StoreRequest StorePath + + AddSignatures + :: StorePath + -> [ByteString] + -> StoreRequest () + + -- | Add temporary garbage collector root. + -- + -- This root is removed as soon as the client exits. + AddIndirectRoot + :: StorePath + -> StoreRequest () + + AddTempRoot + :: StorePath + -> StoreRequest () + + -- | Build paths if they are an actual derivations. + -- + -- If derivation output paths are already valid, do nothing. + BuildPaths + :: Set DerivedPath + -> BuildMode + -> StoreRequest () + + BuildDerivation + :: StorePath + -> Derivation StorePath Text + -> BuildMode + -> StoreRequest BuildResult + + EnsurePath + :: StorePath + -> StoreRequest () + + -- | Find garbage collector roots. + FindRoots + :: StoreRequest (Map ByteString StorePath) + + IsValidPath + :: StorePath + -> StoreRequest Bool + + -- | Query valid paths from set, optionally try to use substitutes. + QueryValidPaths + :: HashSet StorePath + -- ^ Set of @StorePath@s to query + -> SubstituteMode + -- ^ Try substituting missing paths when @SubstituteMode_DoSubstitute@ + -> StoreRequest (HashSet StorePath) + + QueryAllValidPaths + :: StoreRequest (HashSet StorePath) + + QuerySubstitutablePaths + :: HashSet StorePath + -> StoreRequest (HashSet StorePath) + + QueryPathInfo + :: StorePath + -> StoreRequest (Maybe (Metadata StorePath)) + + QueryReferrers + :: StorePath + -> StoreRequest (HashSet StorePath) + + QueryValidDerivers + :: StorePath + -> StoreRequest (HashSet StorePath) + + QueryDerivationOutputs + :: StorePath + -> StoreRequest (HashSet StorePath) + + QueryDerivationOutputNames + :: StorePath + -> StoreRequest (HashSet StorePathName) + + QueryPathFromHashPart + :: StorePathHashPart + -> StoreRequest StorePath + + QueryMissing + :: Set DerivedPath + -> StoreRequest + ( HashSet StorePath -- Paths that will be built + , HashSet StorePath -- Paths that have substitutes + , HashSet StorePath -- Unknown paths + , Integer -- Download size + , Integer -- Nar size? + ) + + OptimiseStore + :: StoreRequest () + + SyncWithGC + :: StoreRequest () + + -- returns True on errors + VerifyStore + :: CheckMode + -> RepairMode + -> StoreRequest Bool From cbbc73151929ceeb561f3dc0eb429a5b61ef9472 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 30 Nov 2023 15:21:16 +0100 Subject: [PATCH 005/104] remote: fix mapStoreConfig import --- hnix-store-remote/tests-io/NixDaemon.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index a2d4087..f55b881 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemon.hs @@ -29,6 +29,7 @@ import System.Nix.Build import System.Nix.StorePath import System.Nix.StorePath.Metadata import System.Nix.Store.Remote +import System.Nix.Store.Remote.MonadStore (mapStoreConfig) import Crypto.Hash (SHA256) import System.Nix.Nar (dumpPath) From 936fdf85f5191ba1ca2750fa21e3b2b65b06918a Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 06:07:32 +0100 Subject: [PATCH 006/104] remote: Data.Serializer, expand signature of mapIso/mapPrism* --- hnix-store-remote/src/Data/Serializer.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/hnix-store-remote/src/Data/Serializer.hs b/hnix-store-remote/src/Data/Serializer.hs index d061743..1a1c601 100644 --- a/hnix-store-remote/src/Data/Serializer.hs +++ b/hnix-store-remote/src/Data/Serializer.hs @@ -151,7 +151,8 @@ mapIsoSerializer :: Functor (t Get) => (a -> b) -- ^ Map over @getS@ -> (b -> a) -- ^ Map over @putS@ - -> (Serializer t a -> Serializer t b) + -> Serializer t a + -> Serializer t b mapIsoSerializer f g s = Serializer { getS = f <$> getS s , putS = putS s . g @@ -163,7 +164,8 @@ mapPrismSerializer :: MonadError eGet (t Get) => (a -> Either eGet b) -- ^ Map over @getS@ -> (b -> a) -- ^ Map over @putS@ - -> (Serializer t a -> Serializer t b) + -> Serializer t a + -> Serializer t b mapPrismSerializer f g s = Serializer { getS = either throwError pure . f =<< getS s , putS = putS s . g From ec79cfe1ce0a2ef2abe6d6d8e4075763aa8991eb Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 06:09:08 +0100 Subject: [PATCH 007/104] remote: NixSerializer, move maybePath from where clause, expose --- .../src/System/Nix/Store/Remote/Serializer.hs | 43 ++++++++++--------- 1 file changed, 22 insertions(+), 21 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index f1b0ce3..520c149 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -33,6 +33,7 @@ module System.Nix.Store.Remote.Serializer , protoVersion -- * StorePath , storePath + , maybePath , storePathHashPart , storePathName -- * Metadata @@ -409,6 +410,27 @@ storePath = Serializer $ System.Nix.StorePath.storePathToRawFilePath sd p } +maybePath + :: HasStoreDir r + => NixSerializer r SError (Maybe StorePath) +maybePath = Serializer + { getS = do + getS maybeText >>= \case + Nothing -> pure Nothing + Just t -> do + sd <- Control.Monad.Reader.asks hasStoreDir + either + (throwError . SError_Path) + (pure . pure) + $ System.Nix.StorePath.parsePathFromText sd t + + , putS = \case + Nothing -> putS maybeText Nothing + Just p -> do + sd <- Control.Monad.Reader.asks hasStoreDir + putS text $ System.Nix.StorePath.storePathToText sd p + } + storePathHashPart :: NixSerializer r SError StorePathHashPart storePathHashPart = mapIsoSerializer @@ -485,27 +507,6 @@ pathMetadata = Serializer (fmap System.Nix.ContentAddress.buildContentAddress) maybeText - maybePath - :: HasStoreDir r - => NixSerializer r SError (Maybe StorePath) - maybePath = Serializer - { getS = do - getS maybeText >>= \case - Nothing -> pure Nothing - Just t -> do - sd <- Control.Monad.Reader.asks hasStoreDir - either - (throwError . SError_Path) - (pure . pure) - $ System.Nix.StorePath.parsePathFromText sd t - - , putS = \case - Nothing -> putS maybeText Nothing - Just p -> do - sd <- Control.Monad.Reader.asks hasStoreDir - putS text $ System.Nix.StorePath.storePathToText sd p - } - storePathTrust :: NixSerializer r SError StorePathTrust storePathTrust = From e57397b99fac9cf46604ef58e0e796058b86fe5e Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 06:15:47 +0100 Subject: [PATCH 008/104] remote: move ourProtoVersion near type, elaborate Types imports in Client --- .../src/System/Nix/Store/Remote/Client.hs | 11 ++++------- .../src/System/Nix/Store/Remote/Types/ProtoVersion.hs | 8 ++++++++ 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index c50856d..41baf36 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -24,13 +24,10 @@ import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore 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 -ourProtoVersion = ProtoVersion - { protoVersion_major = 1 - , protoVersion_minor = 21 - } +import System.Nix.Store.Remote.Types.Logger (Logger) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) +import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig(..), StoreConfig(..)) +import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) workerMagic1 :: Int workerMagic1 = 0x6e697863 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs index f783671..159915b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs @@ -1,6 +1,7 @@ module System.Nix.Store.Remote.Types.ProtoVersion ( ProtoVersion(..) , HasProtoVersion(..) + , ourProtoVersion ) where import Data.Word (Word8, Word16) @@ -17,3 +18,10 @@ class HasProtoVersion r where instance HasProtoVersion ProtoVersion where hasProtoVersion = id + +-- | The protocol version we support +ourProtoVersion :: ProtoVersion +ourProtoVersion = ProtoVersion + { protoVersion_major = 1 + , protoVersion_minor = 21 + } From 78639b83963ac10a8634f8c8689d914a6f208b5b Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 06:25:26 +0100 Subject: [PATCH 009/104] remote: NixSerializer, rename mapError to mapErrorST, add mapErrorS, mapReaderS for transforming `NixSerializer`(s) --- .../src/System/Nix/Store/Remote/Serializer.hs | 47 +++++++++++++++---- 1 file changed, 38 insertions(+), 9 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 520c149..5e7d93e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -9,6 +9,8 @@ module System.Nix.Store.Remote.Serializer ( -- * NixSerializer NixSerializer + , mapReaderS + , mapErrorS -- * Errors , SError(..) -- ** Runners @@ -63,11 +65,11 @@ module System.Nix.Store.Remote.Serializer , verbosity ) where -import Control.Monad.Except (MonadError, throwError, withExceptT) +import Control.Monad.Except (MonadError, throwError, ) import Control.Monad.Reader (MonadReader) import Control.Monad.Trans (MonadTrans, lift) -import Control.Monad.Trans.Reader (ReaderT, runReaderT) -import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT) +import Control.Monad.Trans.Except (ExceptT, mapExceptT, runExceptT, withExceptT) import Crypto.Hash (Digest, HashAlgorithm, SHA256) import Data.ByteString (ByteString) import Data.Dependent.Sum (DSum((:=>))) @@ -146,16 +148,44 @@ runSerialT r = . runExceptT . _unSerialT -mapError +mapErrorST :: Functor m => (e -> e') -> SerialT r e m a -> SerialT r e' m a -mapError f = +mapErrorST f = + SerialT + . withExceptT f + . _unSerialT + +mapErrorS + :: (e -> e') + -> NixSerializer r e a + -> NixSerializer r e' a +mapErrorS f s = Serializer + { getS = mapErrorST f $ getS s + , putS = mapErrorST f . putS s + } + +mapReaderST + :: Functor m + => (r' -> r) + -> SerialT r e m a + -> SerialT r' e m a +mapReaderST f = SerialT - . withExceptT f + . (mapExceptT . withReaderT) f . _unSerialT +mapReaderS + :: (r' -> r) + -> NixSerializer r e a + -> NixSerializer r' e a +mapReaderS f s = Serializer + { getS = mapReaderST f $ getS s + , putS = mapReaderST f . putS s + } + -- * NixSerializer type NixSerializer r e = Serializer (SerialT r e) @@ -677,7 +707,7 @@ mapPrimE :: Functor m => SerialT r SError m a -> SerialT r LoggerSError m a -mapPrimE = mapError LoggerSError_Prim +mapPrimE = mapErrorST LoggerSError_Prim maybeActivity :: NixSerializer r LoggerSError (Maybe Activity) maybeActivity = Serializer @@ -822,8 +852,7 @@ logger = Serializer , putS = \case Logger_Next s -> do putS loggerOpCode LoggerOpCode_Next - mapError LoggerSError_Prim $ - putS text s + mapPrimE $ putS text s Logger_Read i -> do putS loggerOpCode LoggerOpCode_Read From 2c46d342b023c65098bfa1c1511405f5a32b8d09 Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 06:43:30 +0100 Subject: [PATCH 010/104] remote, LoggerOpCode Int -> Word64 --- .../src/System/Nix/Store/Remote/Serialize.hs | 4 ++-- .../src/System/Nix/Store/Remote/Serializer.hs | 6 +++--- .../src/System/Nix/Store/Remote/Types/Logger.hs | 13 +++++++------ 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs index f26e96e..20fafd7 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs @@ -200,8 +200,8 @@ instance Serialize ErrorInfo where putMany put errorInfoTraces instance Serialize LoggerOpCode where - get = getInt @Int >>= either fail pure . intToLoggerOpCode - put = putInt @Int . loggerOpCodeToInt + get = getInt >>= either fail pure . word64ToLoggerOpCode + put = putInt . loggerOpCodeToWord64 instance Serialize Verbosity where get = getEnum diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 5e7d93e..a037e2e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -697,7 +697,7 @@ buildResult = Serializer data LoggerSError = LoggerSError_Prim SError - | LoggerSError_InvalidOpCode Int + | LoggerSError_InvalidOpCode Word64 | LoggerSError_TooOldForErrorInfo | LoggerSError_TooNewForBasicError | LoggerSError_UnknownLogFieldType Word8 @@ -800,8 +800,8 @@ loggerOpCode = Serializer either (pure $ throwError (LoggerSError_InvalidOpCode c)) pure - $ intToLoggerOpCode c - , putS = putS int . loggerOpCodeToInt + $ word64ToLoggerOpCode c + , putS = putS int . loggerOpCodeToWord64 } logger diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs index 779909c..74dd991 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs @@ -5,13 +5,14 @@ module System.Nix.Store.Remote.Types.Logger , ErrorInfo(..) , Logger(..) , LoggerOpCode(..) - , loggerOpCodeToInt - , intToLoggerOpCode + , loggerOpCodeToWord64 + , word64ToLoggerOpCode , isError ) where import Data.ByteString (ByteString) import Data.Text (Text) +import Data.Word (Word64) import GHC.Generics import System.Nix.Store.Remote.Types.Activity (Activity, ActivityID, ActivityResult) import System.Nix.Store.Remote.Types.Verbosity (Verbosity) @@ -55,8 +56,8 @@ data LoggerOpCode | LoggerOpCode_Result deriving (Eq, Generic, Ord, Show) -loggerOpCodeToInt :: LoggerOpCode -> Int -loggerOpCodeToInt = \case +loggerOpCodeToWord64 :: LoggerOpCode -> Word64 +loggerOpCodeToWord64 = \case LoggerOpCode_Next -> 0x6f6c6d67 LoggerOpCode_Read -> 0x64617461 LoggerOpCode_Write -> 0x64617416 @@ -66,8 +67,8 @@ loggerOpCodeToInt = \case LoggerOpCode_StopActivity -> 0x53544f50 LoggerOpCode_Result -> 0x52534c54 -intToLoggerOpCode :: Int -> Either String LoggerOpCode -intToLoggerOpCode = \case +word64ToLoggerOpCode :: Word64 -> Either String LoggerOpCode +word64ToLoggerOpCode = \case 0x6f6c6d67 -> Right LoggerOpCode_Next 0x64617461 -> Right LoggerOpCode_Read 0x64617416 -> Right LoggerOpCode_Write From c5f3c1e4f612eb09eae51064efebb18dce7b8856 Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 07:24:50 +0100 Subject: [PATCH 011/104] remote: generalize error in sockPutS, sockGetS, add Types.WorkerMagic, workerMagic serializer, HandshakeSError --- hnix-store-remote/hnix-store-remote.cabal | 1 + .../src/System/Nix/Store/Remote/Client.hs | 39 ++++++++++++------- .../src/System/Nix/Store/Remote/MonadStore.hs | 4 +- .../src/System/Nix/Store/Remote/Serializer.hs | 20 ++++++++++ .../src/System/Nix/Store/Remote/Socket.hs | 15 +++---- .../src/System/Nix/Store/Remote/Types.hs | 2 + .../Nix/Store/Remote/Types/WorkerMagic.hs | 27 +++++++++++++ 7 files changed, 87 insertions(+), 21 deletions(-) create mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerMagic.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 3f0c18f..63761bb 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -92,6 +92,7 @@ library , System.Nix.Store.Remote.Types.StoreConfig , System.Nix.Store.Remote.Types.SubstituteMode , System.Nix.Store.Remote.Types.Verbosity + , System.Nix.Store.Remote.Types.WorkerMagic , System.Nix.Store.Remote.Types.WorkerOp build-depends: diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 41baf36..152307c 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -23,17 +23,13 @@ import qualified Network.Socket.ByteString import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) -import System.Nix.Store.Remote.Serializer (bool, enum, int, protoVersion, text) +import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, text, workerMagic) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig(..), StoreConfig(..)) +import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) -workerMagic1 :: Int -workerMagic1 = 0x6e697863 -workerMagic2 :: Int -workerMagic2 = 0x6478696f - type Run a = IO (Either RemoteStoreError a, [Logger]) simpleOp :: WorkerOp -> MonadRemoteStore Bool @@ -44,7 +40,7 @@ simpleOpArgs op args = do runOpArgs op args err <- gotError Data.Bool.bool - (sockGetS bool) + (sockGetS $ mapErrorS RemoteStoreError_SerializerGet bool) (do -- TODO: don't use show getErrors >>= throwError . RemoteStoreError_Fixme . show @@ -67,7 +63,7 @@ runOpArgsIO ) -> MonadRemoteStore () runOpArgsIO op encoder = do - sockPutS enum op + sockPutS (mapErrorS RemoteStoreError_SerializerPut enum) op soc <- getStoreSocket encoder (liftIO . Network.Socket.ByteString.sendAll soc) @@ -93,11 +89,22 @@ runStoreSocket preStoreConfig code = where greet :: MonadRemoteStoreHandshake ProtoVersion greet = do - sockPutS int workerMagic1 - magic <- sockGetS int + sockPutS + (mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + ) + WorkerMagic_One + + magic <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + unless - (magic == workerMagic2) + (magic == WorkerMagic_Two) $ throwError RemoteStoreError_WorkerMagic2Mismatch daemonVersion <- sockGetS protoVersion @@ -111,13 +118,19 @@ runStoreSocket preStoreConfig code = $ sockPutS int (0 :: Int) -- affinity, obsolete when (daemonVersion >= ProtoVersion 1 11) $ do - sockPutS bool False -- reserveSpace, obsolete + sockPutS + (mapErrorS RemoteStoreError_SerializerPut 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 + _daemonNixVersion <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerGet + text return () -- TODO do something with it 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 94f19c3..9781383 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -38,7 +38,7 @@ 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.Serializer (HandshakeSError, LoggerSError, SError) import System.Nix.Store.Remote.Types.Logger (Logger, isError) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), PreStoreConfig, StoreConfig) @@ -55,6 +55,8 @@ data RemoteStoreError | RemoteStoreError_Disconnected | RemoteStoreError_GetAddrInfoFailed | RemoteStoreError_SerializerGet SError + | RemoteStoreError_SerializerHandshake HandshakeSError + | RemoteStoreError_SerializerLogger LoggerSError | RemoteStoreError_SerializerPut SError | RemoteStoreError_NoDataProvided | RemoteStoreError_ProtocolMismatch diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index a037e2e..b07a1ce 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -63,6 +63,9 @@ module System.Nix.Store.Remote.Serializer , loggerOpCode , logger , verbosity + -- * Handshake + , HandshakeSError(..) + , workerMagic ) where import Control.Monad.Except (MonadError, throwError, ) @@ -902,3 +905,20 @@ verbosity = Serializer { getS = mapPrimE $ getS enum , putS = mapPrimE . putS enum } + +-- * Handshake + +data HandshakeSError + = HandshakeSError_InvalidWorkerMagic Word64 + deriving (Eq, Ord, Generic, Show) + +workerMagic :: NixSerializer r HandshakeSError WorkerMagic +workerMagic = Serializer + { getS = do + c <- getS int + either + (pure $ throwError (HandshakeSError_InvalidWorkerMagic c)) + pure + $ word64ToWorkerMagic c + , putS = putS int . workerMagicToWord64 + } 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 ad806a7..0ecf563 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -10,7 +10,7 @@ import Data.Serialize.Put (Put, runPut) import Network.Socket.ByteString (recv, sendAll) 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.Serializer (NixSerializer, runP, runSerialT) import System.Nix.Store.Remote.Serialize.Prim (getInt, getByteString, getByteStrings, getPath, getPathsOrFail) import System.Nix.Store.Remote.Types (HasStoreSocket(..)) @@ -50,27 +50,28 @@ sockPut p = do sockPutS :: ( MonadReader r m - , MonadError RemoteStoreError m + , MonadError e m , MonadIO m , HasStoreSocket r ) - => NixSerializer r SError a + => NixSerializer r e a -> a -> m () sockPutS s a = do r <- ask case runP s r a of Right x -> liftIO $ sendAll (hasStoreSocket r) x - Left e -> throwError $ RemoteStoreError_SerializerPut e + Left e -> throwError e sockGetS - :: forall r m a + :: forall r e m a . ( HasStoreSocket r , MonadError RemoteStoreError m + , MonadError e m , MonadReader r m , MonadIO m ) - => NixSerializer r SError a + => NixSerializer r e a -> m a sockGetS s = do r <- ask @@ -79,7 +80,7 @@ sockGetS s = do case res of Right x -> pure x - Left e -> throwError $ RemoteStoreError_SerializerGet e + Left e -> throwError e where sockGet8' :: MonadError RemoteStoreError m => m ByteString sockGet8' = do diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs index f37f122..1dc364b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs @@ -7,6 +7,7 @@ module System.Nix.Store.Remote.Types , module System.Nix.Store.Remote.Types.StoreConfig , module System.Nix.Store.Remote.Types.SubstituteMode , module System.Nix.Store.Remote.Types.Verbosity + , module System.Nix.Store.Remote.Types.WorkerMagic , module System.Nix.Store.Remote.Types.WorkerOp ) where @@ -18,4 +19,5 @@ import System.Nix.Store.Remote.Types.ProtoVersion import System.Nix.Store.Remote.Types.StoreConfig import System.Nix.Store.Remote.Types.SubstituteMode import System.Nix.Store.Remote.Types.Verbosity +import System.Nix.Store.Remote.Types.WorkerMagic import System.Nix.Store.Remote.Types.WorkerOp diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerMagic.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerMagic.hs new file mode 100644 index 0000000..f887826 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerMagic.hs @@ -0,0 +1,27 @@ +module System.Nix.Store.Remote.Types.WorkerMagic + ( WorkerMagic(..) + , workerMagicToWord64 + , word64ToWorkerMagic + ) where + +import Data.Word (Word64) +import GHC.Generics (Generic) + +-- | WorkerMagic +-- +-- Magic numbers exchange during handshake +data WorkerMagic + = WorkerMagic_One + | WorkerMagic_Two + deriving (Eq, Generic, Ord, Show) + +workerMagicToWord64 :: WorkerMagic -> Word64 +workerMagicToWord64 = \case + WorkerMagic_One -> 0x6e697863 + WorkerMagic_Two -> 0x6478696f + +word64ToWorkerMagic :: Word64 -> Either String WorkerMagic +word64ToWorkerMagic = \case + 0x6e697863 -> Right WorkerMagic_One + 0x6478696f -> Right WorkerMagic_Two + x -> Left $ "Invalid WorkerMagic: " ++ show x From e0456e3bc97d12a56f216ddb5d3c639aa693d119 Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 08:08:00 +0100 Subject: [PATCH 012/104] remote: prefix WorkerOp, add workerOp Serializer, test --- .../src/System/Nix/Store/Remote.hs | 50 +++++----- .../src/System/Nix/Store/Remote/Serializer.hs | 8 ++ .../System/Nix/Store/Remote/Types/WorkerOp.hs | 94 +++++++++---------- hnix-store-remote/tests/NixSerializerSpec.hs | 35 +++++-- 4 files changed, 106 insertions(+), 81 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index b51ce2b..aa582ed 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -158,7 +158,7 @@ addToStore name source recursive repair = do Control.Monad.when (repair == RepairMode_DoRepair) $ error "repairing is not supported when building through the Nix daemon" - runOpArgsIO AddToStore $ \yield -> do + runOpArgsIO WorkerOp_AddToStore $ \yield -> do yield $ Data.Serialize.Put.runPut $ do putText $ System.Nix.StorePath.unStorePathName name putBool @@ -186,7 +186,7 @@ addTextToStore name text references' repair = do $ error "repairing is not supported when building through the Nix daemon" storeDir <- getStoreDir - runOpArgs AddTextToStore $ do + runOpArgs WorkerOp_AddTextToStore $ do putText name putText text putPaths storeDir references' @@ -195,14 +195,14 @@ addTextToStore name text references' repair = do addSignatures :: StorePath -> [ByteString] -> MonadStore () addSignatures p signatures = do storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs AddSignatures $ do + Control.Monad.void $ simpleOpArgs WorkerOp_AddSignatures $ do putPath storeDir p putByteStrings signatures addIndirectRoot :: StorePath -> MonadStore () addIndirectRoot pn = do storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs AddIndirectRoot $ putPath storeDir pn + Control.Monad.void $ simpleOpArgs WorkerOp_AddIndirectRoot $ putPath storeDir pn -- | Add temporary garbage collector root. -- @@ -210,7 +210,7 @@ addIndirectRoot pn = do addTempRoot :: StorePath -> MonadStore () addTempRoot pn = do storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs AddTempRoot $ putPath storeDir pn + Control.Monad.void $ simpleOpArgs WorkerOp_AddTempRoot $ putPath storeDir pn -- | Build paths if they are an actual derivations. -- @@ -218,7 +218,7 @@ addTempRoot pn = do buildPaths :: HashSet StorePath -> BuildMode -> MonadStore () buildPaths ps bm = do storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs BuildPaths $ do + Control.Monad.void $ simpleOpArgs WorkerOp_BuildPaths $ do putPaths storeDir ps putInt $ fromEnum bm @@ -229,7 +229,7 @@ buildDerivation -> MonadStore BuildResult buildDerivation p drv buildMode = do storeDir <- getStoreDir - runOpArgs BuildDerivation $ do + runOpArgs WorkerOp_BuildDerivation $ do putPath storeDir p putDerivation storeDir drv putEnum buildMode @@ -247,7 +247,7 @@ deleteSpecific -> MonadStore GCResult deleteSpecific paths = do storeDir <- getStoreDir - runOpArgs CollectGarbage $ do + runOpArgs WorkerOp_CollectGarbage $ do putEnum GCAction_DeleteSpecific putPaths storeDir paths putBool False -- ignoreLiveness @@ -265,12 +265,14 @@ deleteSpecific paths = do ensurePath :: StorePath -> MonadStore () ensurePath pn = do storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs EnsurePath $ putPath storeDir pn + Control.Monad.void + $ simpleOpArgs WorkerOp_EnsurePath + $ putPath storeDir pn -- | Find garbage collector roots. findRoots :: MonadStore (Map ByteString StorePath) findRoots = do - runOp FindRoots + runOp WorkerOp_FindRoots sd <- getStoreDir res <- getSocketIncremental @@ -292,7 +294,7 @@ findRoots = do isValidPathUncached :: StorePath -> MonadStore Bool isValidPathUncached p = do storeDir <- getStoreDir - simpleOpArgs IsValidPath $ putPath storeDir p + simpleOpArgs WorkerOp_IsValidPath $ putPath storeDir p -- | Query valid paths from set, optionally try to use substitutes. queryValidPaths @@ -301,26 +303,26 @@ queryValidPaths -> MonadStore (HashSet StorePath) queryValidPaths ps substitute = do storeDir <- getStoreDir - runOpArgs QueryValidPaths $ do + runOpArgs WorkerOp_QueryValidPaths $ do putPaths storeDir ps putBool $ substitute == SubstituteMode_DoSubstitute sockGetPaths queryAllValidPaths :: MonadStore (HashSet StorePath) queryAllValidPaths = do - runOp QueryAllValidPaths + runOp WorkerOp_QueryAllValidPaths sockGetPaths querySubstitutablePaths :: HashSet StorePath -> MonadStore (HashSet StorePath) querySubstitutablePaths ps = do storeDir <- getStoreDir - runOpArgs QuerySubstitutablePaths $ putPaths storeDir ps + runOpArgs WorkerOp_QuerySubstitutablePaths $ putPaths storeDir ps sockGetPaths queryPathInfoUncached :: StorePath -> MonadStore (Metadata StorePath) queryPathInfoUncached path = do storeDir <- getStoreDir - runOpArgs QueryPathInfo $ do + runOpArgs WorkerOp_QueryPathInfo $ do putPath storeDir path valid <- sockGetBool @@ -369,30 +371,30 @@ queryPathInfoUncached path = do queryReferrers :: StorePath -> MonadStore (HashSet StorePath) queryReferrers p = do storeDir <- getStoreDir - runOpArgs QueryReferrers $ putPath storeDir p + runOpArgs WorkerOp_QueryReferrers $ putPath storeDir p sockGetPaths queryValidDerivers :: StorePath -> MonadStore (HashSet StorePath) queryValidDerivers p = do storeDir <- getStoreDir - runOpArgs QueryValidDerivers $ putPath storeDir p + runOpArgs WorkerOp_QueryValidDerivers $ putPath storeDir p sockGetPaths queryDerivationOutputs :: StorePath -> MonadStore (HashSet StorePath) queryDerivationOutputs p = do storeDir <- getStoreDir - runOpArgs QueryDerivationOutputs $ putPath storeDir p + runOpArgs WorkerOp_QueryDerivationOutputs $ putPath storeDir p sockGetPaths queryDerivationOutputNames :: StorePath -> MonadStore (HashSet StorePath) queryDerivationOutputNames p = do storeDir <- getStoreDir - runOpArgs QueryDerivationOutputNames $ putPath storeDir p + runOpArgs WorkerOp_QueryDerivationOutputNames $ putPath storeDir p sockGetPaths queryPathFromHashPart :: StorePathHashPart -> MonadStore StorePath queryPathFromHashPart storePathHash = do - runOpArgs QueryPathFromHashPart + runOpArgs WorkerOp_QueryPathFromHashPart $ putText $ System.Nix.StorePath.storePathHashPartToText storePathHash sockGetPath @@ -408,7 +410,7 @@ queryMissing ) queryMissing ps = do storeDir <- getStoreDir - runOpArgs QueryMissing $ putPaths storeDir ps + runOpArgs WorkerOp_QueryMissing $ putPaths storeDir ps willBuild <- sockGetPaths willSubstitute <- sockGetPaths @@ -418,13 +420,13 @@ queryMissing ps = do pure (willBuild, willSubstitute, unknown, downloadSize', narSize') optimiseStore :: MonadStore () -optimiseStore = Control.Monad.void $ simpleOp OptimiseStore +optimiseStore = Control.Monad.void $ simpleOp WorkerOp_OptimiseStore syncWithGC :: MonadStore () -syncWithGC = Control.Monad.void $ simpleOp SyncWithGC +syncWithGC = Control.Monad.void $ simpleOp WorkerOp_SyncWithGC -- returns True on errors verifyStore :: CheckMode -> RepairMode -> MonadStore Bool -verifyStore check repair = simpleOpArgs VerifyStore $ do +verifyStore check repair = simpleOpArgs WorkerOp_VerifyStore $ do putBool $ check == CheckMode_DoCheck putBool $ repair == RepairMode_DoRepair diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index b07a1ce..0738e63 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -66,6 +66,8 @@ module System.Nix.Store.Remote.Serializer -- * Handshake , HandshakeSError(..) , workerMagic + -- * Worker protocol + , workerOp ) where import Control.Monad.Except (MonadError, throwError, ) @@ -922,3 +924,9 @@ workerMagic = Serializer $ word64ToWorkerMagic c , putS = putS int . workerMagicToWord64 } + +-- * Worker protocol + +workerOp :: NixSerializer r SError WorkerOp +workerOp = enum + diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs index 6fd18f9..c250db2 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs @@ -7,51 +7,51 @@ module System.Nix.Store.Remote.Types.WorkerOp -- This type has gaps filled in so that the GHC builtin -- Enum instance lands on the right values. data WorkerOp - = Reserved_0__ -- 0 - | IsValidPath -- 1 - | Reserved_2__ -- 2 - | HasSubstitutes -- 3 - | QueryPathHash -- 4 // obsolete - | QueryReferences -- 5 // obsolete - | QueryReferrers -- 6 - | AddToStore -- 7 - | AddTextToStore -- 8 // obsolete since 1.25, Nix 3.0. Use wopAddToStore - | BuildPaths -- 9 - | EnsurePath -- 10 0xa - | AddTempRoot -- 11 0xb - | AddIndirectRoot -- 12 0xc - | SyncWithGC -- 13 0xd - | FindRoots -- 14 0xe - | Reserved_15__ -- 15 0xf - | ExportPath -- 16 0x10 // obsolete - | Reserved_17__ -- 17 0x11 - | QueryDeriver -- 18 0x12 // obsolete - | SetOptions -- 19 0x13 - | CollectGarbage -- 20 0x14 - | QuerySubstitutablePathInfo -- 21 0x15 - | QueryDerivationOutputs -- 22 0x16 // obsolete - | QueryAllValidPaths -- 23 0x17 - | QueryFailedPaths -- 24 0x18 - | ClearFailedPaths -- 25 0x19 - | QueryPathInfo -- 26 0x1a - | ImportPaths -- 27 0x1b // obsolete - | QueryDerivationOutputNames -- 28 0x1c // obsolete - | QueryPathFromHashPart -- 29 0x1d - | QuerySubstitutablePathInfos -- 30 0x1e - | QueryValidPaths -- 31 0x1f - | QuerySubstitutablePaths -- 32 0x20 - | QueryValidDerivers -- 33 0x21 - | OptimiseStore -- 34 0x22 - | VerifyStore -- 35 0x23 - | BuildDerivation -- 36 0x24 - | AddSignatures -- 37 0x25 - | NarFromPath -- 38 0x26 - | AddToStoreNar -- 39 0x27 - | QueryMissing -- 40 0x28 - | QueryDerivationOutputMap -- 41 0x29 - | RegisterDrvOutput -- 42 0x2a - | QueryRealisation -- 43 0x2b - | AddMultipleToStore -- 44 0x2c - | AddBuildLog -- 45 0x2d - | BuildPathsWithResults -- 46 0x2e + = WorkerOp_Reserved_0__ -- 0 + | WorkerOp_IsValidPath -- 1 + | WorkerOp_Reserved_2__ -- 2 + | WorkerOp_HasSubstitutes -- 3 + | WorkerOp_QueryPathHash -- 4 // obsolete + | WorkerOp_QueryReferences -- 5 // obsolete + | WorkerOp_QueryReferrers -- 6 + | WorkerOp_AddToStore -- 7 + | WorkerOp_AddTextToStore -- 8 // obsolete since 1.25, Nix 3.0. Use wopAddToStore + | WorkerOp_BuildPaths -- 9 + | WorkerOp_EnsurePath -- 10 0xa + | WorkerOp_AddTempRoot -- 11 0xb + | WorkerOp_AddIndirectRoot -- 12 0xc + | WorkerOp_SyncWithGC -- 13 0xd + | WorkerOp_FindRoots -- 14 0xe + | WorkerOp_Reserved_15__ -- 15 0xf + | WorkerOp_ExportPath -- 16 0x10 // obsolete + | WorkerOp_Reserved_17__ -- 17 0x11 + | WorkerOp_QueryDeriver -- 18 0x12 // obsolete + | WorkerOp_SetOptions -- 19 0x13 + | WorkerOp_CollectGarbage -- 20 0x14 + | WorkerOp_QuerySubstitutablePathInfo -- 21 0x15 + | WorkerOp_QueryDerivationOutputs -- 22 0x16 // obsolete + | WorkerOp_QueryAllValidPaths -- 23 0x17 + | WorkerOp_QueryFailedPaths -- 24 0x18 + | WorkerOp_ClearFailedPaths -- 25 0x19 + | WorkerOp_QueryPathInfo -- 26 0x1a + | WorkerOp_ImportPaths -- 27 0x1b // obsolete + | WorkerOp_QueryDerivationOutputNames -- 28 0x1c // obsolete + | WorkerOp_QueryPathFromHashPart -- 29 0x1d + | WorkerOp_QuerySubstitutablePathInfos -- 30 0x1e + | WorkerOp_QueryValidPaths -- 31 0x1f + | WorkerOp_QuerySubstitutablePaths -- 32 0x20 + | WorkerOp_QueryValidDerivers -- 33 0x21 + | WorkerOp_OptimiseStore -- 34 0x22 + | WorkerOp_VerifyStore -- 35 0x23 + | WorkerOp_BuildDerivation -- 36 0x24 + | WorkerOp_AddSignatures -- 37 0x25 + | WorkerOp_NarFromPath -- 38 0x26 + | WorkerOp_AddToStoreNar -- 39 0x27 + | WorkerOp_QueryMissing -- 40 0x28 + | WorkerOp_QueryDerivationOutputMap -- 41 0x29 + | WorkerOp_RegisterDrvOutput -- 42 0x2a + | WorkerOp_QueryRealisation -- 43 0x2b + | WorkerOp_AddMultipleToStore -- 44 0x2c + | WorkerOp_AddBuildLog -- 45 0x2d + | WorkerOp_BuildPathsWithResults -- 46 0x2e deriving (Bounded, Eq, Enum, Ord, Show, Read) diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 9356bf2..e85fd2e 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -6,7 +6,8 @@ import Crypto.Hash (MD5, SHA1, SHA256, SHA512) import Data.Dependent.Sum (DSum((:=>))) import Data.Fixed (Uni) import Data.Time (NominalDiffTime) -import Test.Hspec (Expectation, Spec, describe, parallel, shouldBe) +import Data.Word (Word64) +import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, arbitrary, forAll, suchThat) import Test.QuickCheck.Instances () @@ -23,7 +24,7 @@ import System.Nix.StorePath (StoreDir) import System.Nix.StorePath.Metadata (Metadata(..)) import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serializer -import System.Nix.Store.Remote.Types (ErrorInfo(..), Logger(..), ProtoVersion(..), Trace(..)) +import System.Nix.Store.Remote.Types (ErrorInfo(..), Logger(..), ProtoVersion(..), Trace(..), WorkerOp(..)) -- | Test for roundtrip using @NixSerializer@ roundtripSReader @@ -154,11 +155,25 @@ spec = parallel $ do $ \pv -> forAll (arbitrary `suchThat` errorInfoIf (protoVersion_minor pv >= 26)) $ roundtripSReader logger pv - where - errorInfoIf True (Logger_Error (Right x)) = noJust0s x - errorInfoIf False (Logger_Error (Left _)) = True - errorInfoIf _ (Logger_Error _) = False - errorInfoIf _ _ = True - noJust0s ErrorInfo{..} = - errorInfoPosition /= Just 0 - && all ((/= Just 0) . tracePosition) errorInfoTraces + + describe "Enums" $ do + let it' name constr value = + it name + $ (runP enum () constr) + `shouldBe` + (runP (int @Word64) () value) + + describe "WorkerOp enum order matches Nix" $ do + it' "IsValidPath" WorkerOp_IsValidPath 1 + it' "BuildPathsWithResults" WorkerOp_BuildPathsWithResults 46 + +errorInfoIf :: Bool -> Logger -> Bool +errorInfoIf True (Logger_Error (Right x)) = noJust0s x + where + noJust0s :: ErrorInfo -> Bool + noJust0s ErrorInfo{..} = + errorInfoPosition /= Just 0 + && all ((/= Just 0) . tracePosition) errorInfoTraces +errorInfoIf False (Logger_Error (Left _)) = True +errorInfoIf _ (Logger_Error _) = False +errorInfoIf _ _ = True From 7f9c7fb2eb46b69c0b88c3e66d403f22971928b1 Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 10:11:18 +0100 Subject: [PATCH 013/104] remote: add/derive instances for StoreRequest --- hnix-store-remote/hnix-store-remote.cabal | 2 + .../src/System/Nix/Store/Remote/Arbitrary.hs | 38 ++++++++++++- .../src/System/Nix/Store/Remote/GADT.hs | 53 +++++++++++++++++-- 3 files changed, 87 insertions(+), 6 deletions(-) diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 63761bb..413268c 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -99,6 +99,7 @@ library base >=4.12 && <5 , hnix-store-core >= 0.8 && <0.9 , hnix-store-nar >= 0.1 + , hnix-store-tests >= 0.1 , attoparsec , bytestring , cereal @@ -106,6 +107,7 @@ library , crypton , data-default-class , dependent-sum > 0.7 && < 1 + , dependent-sum-template > 0.1.1 && < 0.3 , generic-arbitrary < 1.1 , hashable , text diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index e1e7a01..152d5ba 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -3,12 +3,21 @@ {-# OPTIONS_GHC -Wno-orphans #-} module System.Nix.Store.Remote.Arbitrary where +import Data.Some (Some(Some)) +import System.Nix.Arbitrary () +import System.Nix.Store.Remote.GADT import System.Nix.Store.Remote.Types -import Test.QuickCheck (Arbitrary(..)) +import Test.QuickCheck (Arbitrary(..), oneof) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) import Test.QuickCheck.Instances () +deriving via GenericArbitrary CheckMode + instance Arbitrary CheckMode + +deriving via GenericArbitrary SubstituteMode + instance Arbitrary SubstituteMode + deriving via GenericArbitrary ProtoVersion instance Arbitrary ProtoVersion @@ -43,3 +52,30 @@ deriving via GenericArbitrary Logger deriving via GenericArbitrary Verbosity instance Arbitrary Verbosity + +instance Arbitrary (Some StoreRequest) where + arbitrary = oneof + [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) + , Some <$> (AddTextToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) + , Some <$> (AddSignatures <$> arbitrary <*> arbitrary) + , Some . AddIndirectRoot <$> arbitrary + , Some . AddTempRoot <$> arbitrary + , Some <$> (BuildPaths <$> arbitrary <*> arbitrary) + , Some <$> (BuildDerivation <$> arbitrary <*> arbitrary <*> arbitrary) + , Some . EnsurePath <$> arbitrary + , pure $ Some FindRoots + , Some . IsValidPath <$> arbitrary + , Some <$> (QueryValidPaths <$> arbitrary <*> arbitrary) + , pure $ Some QueryAllValidPaths + , Some . QuerySubstitutablePaths <$> arbitrary + , Some . QueryPathInfo <$> arbitrary + , Some . QueryReferrers <$> arbitrary + , Some . QueryValidDerivers <$> arbitrary + , Some . QueryDerivationOutputs <$> arbitrary + , Some . QueryDerivationOutputNames <$> arbitrary + , Some . QueryPathFromHashPart <$> arbitrary + , Some . QueryMissing <$> arbitrary + , pure $ Some OptimiseStore + , pure $ Some SyncWithGC + , Some <$> (VerifyStore <$> arbitrary <*> arbitrary) + ] diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs b/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs index 867e64d..20310f9 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs @@ -1,24 +1,25 @@ {-# language GADTs #-} {-# language Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} module System.Nix.Store.Remote.GADT ( StoreRequest(..) ) where -import Control.Monad.IO.Class (MonadIO) import Data.ByteString (ByteString) +import Data.GADT.Compare.TH (deriveGEq, deriveGCompare) +import Data.GADT.Show.TH (deriveGShow) import Data.HashSet (HashSet) import Data.Kind (Type) import Data.Map (Map) import Data.Set (Set) import Data.Text (Text) -import Data.Some (Some) +import Data.Some (Some(Some)) 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) import System.Nix.Store.Types (RepairMode) import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) import System.Nix.StorePath.Metadata (Metadata) @@ -30,8 +31,16 @@ data StoreRequest :: Type -> Type where AddToStore :: StorePathName -- ^ Name part of the newly created @StorePath@ -> Bool -- ^ Add target directory recursively - -> Some HashAlgo - -> (forall m . MonadIO m => NarSource m) -- ^ provide nar stream + -> Some HashAlgo -- ^ Nar hashing algorithm +-- -> (forall m . MonadIO m => NarSource m) -- ^ provide nar stream +-- Not part of StoreRequest +-- as it would require StoreRequest (m :: Type -> Type) :: Type -> Type +-- for which we cannot derive anything +-- +-- Also the thing is the only special case +-- and it is always sent *after* the other +-- information so it can be handled +-- separately after that. Hopefully. -> RepairMode -- ^ Only used by local store backend -> StoreRequest StorePath @@ -148,3 +157,37 @@ data StoreRequest :: Type -> Type where :: CheckMode -> RepairMode -> StoreRequest Bool + +deriving instance Eq (StoreRequest a) +deriving instance Show (StoreRequest a) + +deriveGEq ''StoreRequest +deriveGCompare ''StoreRequest +deriveGShow ''StoreRequest + +instance {-# OVERLAPPING #-} Eq (Some StoreRequest) where + Some (AddToStore a b c d) == Some (AddToStore a' b' c' d') = (a, b, c, d) == (a', b', c', d') + Some (AddTextToStore a b c d) == Some (AddTextToStore a' b' c' d') = (a, b, c, d) == (a', b', c', d') + Some (AddSignatures a b) == Some (AddSignatures a' b') = (a, b) == (a', b') + Some (AddIndirectRoot a) == Some (AddIndirectRoot a') = a == a' + Some (AddTempRoot a) == Some (AddTempRoot a') = a == a' + Some (BuildPaths a b) == Some (BuildPaths a' b') = (a, b) == (a', b') + Some (BuildDerivation a b c) == Some (BuildDerivation a' b' c') = (a, b, c) == (a', b', c') + Some (EnsurePath a) == Some (EnsurePath a') = a == a' + Some (FindRoots) == Some (FindRoots) = True + Some (IsValidPath a) == Some (IsValidPath a') = a == a' + Some (QueryValidPaths a b) == Some (QueryValidPaths a' b') = (a, b) == (a', b') + Some QueryAllValidPaths == Some QueryAllValidPaths = True + Some (QuerySubstitutablePaths a) == Some (QuerySubstitutablePaths a') = a == a' + Some (QueryPathInfo a) == Some (QueryPathInfo a') = a == a' + Some (QueryReferrers a) == Some (QueryReferrers a') = a == a' + Some (QueryValidDerivers a) == Some (QueryValidDerivers a') = a == a' + Some (QueryDerivationOutputs a) == Some (QueryDerivationOutputs a') = a == a' + Some (QueryDerivationOutputNames a) == Some (QueryDerivationOutputNames a') = a == a' + Some (QueryPathFromHashPart a) == Some (QueryPathFromHashPart a') = a == a' + Some (QueryMissing a) == Some (QueryMissing a') = a == a' + Some OptimiseStore == Some OptimiseStore = True + Some SyncWithGC == Some SyncWithGC = True + Some (VerifyStore a b) == Some (VerifyStore a' b') = (a, b) == (a', b') + + _ == _ = False From 0ab79e5157202df54b331f7c7c0585f49afe54ed Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 10:39:00 +0100 Subject: [PATCH 014/104] remote: add Types.StoreText, use in AddTextToStore --- hnix-store-remote/hnix-store-remote.cabal | 1 + .../src/System/Nix/Store/Remote/Arbitrary.hs | 5 ++++- .../src/System/Nix/Store/Remote/GADT.hs | 6 +++--- .../src/System/Nix/Store/Remote/Serializer.hs | 12 ++++++++++++ .../src/System/Nix/Store/Remote/Types.hs | 2 ++ .../src/System/Nix/Store/Remote/Types/StoreText.hs | 12 ++++++++++++ hnix-store-remote/tests/NixSerializerSpec.hs | 3 +++ 7 files changed, 37 insertions(+), 4 deletions(-) create mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreText.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 413268c..30c82f7 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -90,6 +90,7 @@ library , System.Nix.Store.Remote.Types.Logger , System.Nix.Store.Remote.Types.ProtoVersion , System.Nix.Store.Remote.Types.StoreConfig + , System.Nix.Store.Remote.Types.StoreText , System.Nix.Store.Remote.Types.SubstituteMode , System.Nix.Store.Remote.Types.Verbosity , System.Nix.Store.Remote.Types.WorkerMagic diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index 152d5ba..8bcf099 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -21,6 +21,9 @@ deriving via GenericArbitrary SubstituteMode deriving via GenericArbitrary ProtoVersion instance Arbitrary ProtoVersion +deriving via GenericArbitrary StoreText + instance Arbitrary StoreText + -- * Logger deriving via GenericArbitrary Activity @@ -56,7 +59,7 @@ deriving via GenericArbitrary Verbosity instance Arbitrary (Some StoreRequest) where arbitrary = oneof [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) - , Some <$> (AddTextToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) + , Some <$> (AddTextToStore <$> arbitrary <*> arbitrary <*> arbitrary) , Some <$> (AddSignatures <$> arbitrary <*> arbitrary) , Some . AddIndirectRoot <$> arbitrary , Some . AddTempRoot <$> arbitrary diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs b/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs index 20310f9..efa562d 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs @@ -24,6 +24,7 @@ import System.Nix.Store.Types (RepairMode) import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.Types.CheckMode (CheckMode) +import System.Nix.Store.Remote.Types.StoreText (StoreText) import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode) data StoreRequest :: Type -> Type where @@ -49,8 +50,7 @@ data StoreRequest :: Type -> Type where -- Reference accepts repair but only uses it -- to throw error in case of remote talking to nix-daemon. AddTextToStore - :: Text -- ^ Name of the text - -> Text -- ^ Actual text to add + :: StoreText -> HashSet StorePath -- ^ Set of @StorePath@s that the added text references -> RepairMode -- ^ Repair mode, must be @RepairMode_DontRepair@ in case of remote backend -> StoreRequest StorePath @@ -167,7 +167,7 @@ deriveGShow ''StoreRequest instance {-# OVERLAPPING #-} Eq (Some StoreRequest) where Some (AddToStore a b c d) == Some (AddToStore a' b' c' d') = (a, b, c, d) == (a', b', c', d') - Some (AddTextToStore a b c d) == Some (AddTextToStore a' b' c' d') = (a, b, c, d) == (a', b', c', d') + Some (AddTextToStore a b c) == Some (AddTextToStore a' b' c') = (a, b, c) == (a', b', c') Some (AddSignatures a b) == Some (AddSignatures a' b') = (a, b) == (a', b') Some (AddIndirectRoot a) == Some (AddIndirectRoot a') = a == a' Some (AddTempRoot a) == Some (AddTempRoot a') = a == a' diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 0738e63..270931c 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -67,6 +67,7 @@ module System.Nix.Store.Remote.Serializer , HandshakeSError(..) , workerMagic -- * Worker protocol + , storeText , workerOp ) where @@ -927,6 +928,17 @@ workerMagic = Serializer -- * Worker protocol +storeText :: NixSerializer r SError StoreText +storeText = Serializer + { getS = do + storeTextName <- getS storePathName + storeTextText <- getS text + pure StoreText{..} + , putS = \StoreText{..} -> do + putS storePathName storeTextName + putS text storeTextText + } + workerOp :: NixSerializer r SError WorkerOp workerOp = enum diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs index 1dc364b..6bed0af 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs @@ -5,6 +5,7 @@ module System.Nix.Store.Remote.Types , module System.Nix.Store.Remote.Types.Logger , module System.Nix.Store.Remote.Types.ProtoVersion , module System.Nix.Store.Remote.Types.StoreConfig + , module System.Nix.Store.Remote.Types.StoreText , module System.Nix.Store.Remote.Types.SubstituteMode , module System.Nix.Store.Remote.Types.Verbosity , module System.Nix.Store.Remote.Types.WorkerMagic @@ -17,6 +18,7 @@ import System.Nix.Store.Remote.Types.CheckMode import System.Nix.Store.Remote.Types.Logger import System.Nix.Store.Remote.Types.ProtoVersion import System.Nix.Store.Remote.Types.StoreConfig +import System.Nix.Store.Remote.Types.StoreText import System.Nix.Store.Remote.Types.SubstituteMode import System.Nix.Store.Remote.Types.Verbosity import System.Nix.Store.Remote.Types.WorkerMagic diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreText.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreText.hs new file mode 100644 index 0000000..1814edf --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreText.hs @@ -0,0 +1,12 @@ +module System.Nix.Store.Remote.Types.StoreText + ( StoreText(..) + ) where + +import Data.Text (Text) +import GHC.Generics (Generic) +import System.Nix.StorePath (StorePathName) + +data StoreText = StoreText + { storeTextName :: StorePathName + , storeTextText :: Text + } deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index e85fd2e..5d1918d 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -167,6 +167,9 @@ spec = parallel $ do it' "IsValidPath" WorkerOp_IsValidPath 1 it' "BuildPathsWithResults" WorkerOp_BuildPathsWithResults 46 + describe "Worker protocol" $ do + prop "StoreText" $ roundtripS storeText + errorInfoIf :: Bool -> Logger -> Bool errorInfoIf True (Logger_Error (Right x)) = noJust0s x where From ee172f077f604cc285dbef58b0791212e6487830 Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 11:10:31 +0100 Subject: [PATCH 015/104] remote: add TestStoreConfig --- .../src/System/Nix/Store/Remote/Arbitrary.hs | 3 +++ .../Nix/Store/Remote/Types/StoreConfig.hs | 19 ++++++++++++++++--- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index 8bcf099..1deaf48 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -18,6 +18,9 @@ deriving via GenericArbitrary CheckMode deriving via GenericArbitrary SubstituteMode instance Arbitrary SubstituteMode +deriving via GenericArbitrary TestStoreConfig + instance Arbitrary TestStoreConfig + deriving via GenericArbitrary ProtoVersion instance Arbitrary ProtoVersion diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs index e482393..db30b74 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs @@ -2,15 +2,17 @@ module System.Nix.Store.Remote.Types.StoreConfig ( PreStoreConfig(..) , StoreConfig(..) + , TestStoreConfig(..) , HasStoreSocket(..) ) where +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_dir :: StoreDir , preStoreConfig_socket :: Socket } @@ -27,9 +29,9 @@ instance HasStoreSocket PreStoreConfig where hasStoreSocket = preStoreConfig_socket data StoreConfig = StoreConfig - { storeConfig_dir :: StoreDir + { storeConfig_dir :: StoreDir , storeConfig_protoVersion :: ProtoVersion - , storeConfig_socket :: Socket + , storeConfig_socket :: Socket } instance HasStoreDir StoreDir where @@ -43,3 +45,14 @@ instance HasProtoVersion StoreConfig where instance HasStoreSocket StoreConfig where hasStoreSocket = storeConfig_socket + +data TestStoreConfig = TestStoreConfig + { testStoreConfig_dir :: StoreDir + , testStoreConfig_protoVersion :: ProtoVersion + } deriving (Eq, Generic, Ord, Show) + +instance HasProtoVersion TestStoreConfig where + hasProtoVersion = testStoreConfig_protoVersion + +instance HasStoreDir TestStoreConfig where + hasStoreDir = testStoreConfig_dir From dbc118fc274f14ae4e5cbfc0c5b5628f4c7c815c Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 11:11:55 +0100 Subject: [PATCH 016/104] docs/contributors: add ryantrinkle --- docs/01-Contributors.org | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/01-Contributors.org b/docs/01-Contributors.org index 3302cc4..48d86fa 100644 --- a/docs/01-Contributors.org +++ b/docs/01-Contributors.org @@ -28,3 +28,4 @@ in order of appearance: + Luigy Leon @luigy + squalus @squalus + Vaibhav Sagar @vaibhavsagar +* Ryan Trinkle @ryantrinkle From fcbcafa99a50421d6a11afb3dbed04fe3c9712c3 Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 12:04:23 +0100 Subject: [PATCH 017/104] remote: GADT -> Types.StoreRequest --- hnix-store-remote/hnix-store-remote.cabal | 2 +- hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs | 1 - hnix-store-remote/src/System/Nix/Store/Remote/Types.hs | 2 ++ .../Nix/Store/Remote/{GADT.hs => Types/StoreRequest.hs} | 6 +++--- 4 files changed, 6 insertions(+), 5 deletions(-) rename hnix-store-remote/src/System/Nix/Store/Remote/{GADT.hs => Types/StoreRequest.hs} (98%) diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 30c82f7..53953f7 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -76,7 +76,6 @@ library , System.Nix.Store.Remote , System.Nix.Store.Remote.Arbitrary , System.Nix.Store.Remote.Client - , System.Nix.Store.Remote.GADT , System.Nix.Store.Remote.Logger , System.Nix.Store.Remote.MonadStore , System.Nix.Store.Remote.Serialize @@ -90,6 +89,7 @@ library , System.Nix.Store.Remote.Types.Logger , System.Nix.Store.Remote.Types.ProtoVersion , System.Nix.Store.Remote.Types.StoreConfig + , System.Nix.Store.Remote.Types.StoreRequest , System.Nix.Store.Remote.Types.StoreText , System.Nix.Store.Remote.Types.SubstituteMode , System.Nix.Store.Remote.Types.Verbosity diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index 1deaf48..485d0df 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -5,7 +5,6 @@ module System.Nix.Store.Remote.Arbitrary where import Data.Some (Some(Some)) import System.Nix.Arbitrary () -import System.Nix.Store.Remote.GADT import System.Nix.Store.Remote.Types import Test.QuickCheck (Arbitrary(..), oneof) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs index 6bed0af..d804263 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs @@ -5,6 +5,7 @@ module System.Nix.Store.Remote.Types , module System.Nix.Store.Remote.Types.Logger , module System.Nix.Store.Remote.Types.ProtoVersion , module System.Nix.Store.Remote.Types.StoreConfig + , module System.Nix.Store.Remote.Types.StoreRequest , module System.Nix.Store.Remote.Types.StoreText , module System.Nix.Store.Remote.Types.SubstituteMode , module System.Nix.Store.Remote.Types.Verbosity @@ -18,6 +19,7 @@ import System.Nix.Store.Remote.Types.CheckMode import System.Nix.Store.Remote.Types.Logger import System.Nix.Store.Remote.Types.ProtoVersion import System.Nix.Store.Remote.Types.StoreConfig +import System.Nix.Store.Remote.Types.StoreRequest import System.Nix.Store.Remote.Types.StoreText import System.Nix.Store.Remote.Types.SubstituteMode import System.Nix.Store.Remote.Types.Verbosity diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs similarity index 98% rename from hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs rename to hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs index efa562d..4b5589a 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/GADT.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -1,8 +1,8 @@ -{-# language GADTs #-} -{-# language Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} -module System.Nix.Store.Remote.GADT +module System.Nix.Store.Remote.Types.StoreRequest ( StoreRequest(..) ) where From b2c31e0c7b9a77fcc2860b26b62e20e36a8a0bba Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 12:16:38 +0100 Subject: [PATCH 018/104] remote: recursive Bool -> FileIngestionMethod --- .../src/System/Nix/Store/Remote/Types/StoreRequest.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs index 4b5589a..fb409be 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -20,7 +20,7 @@ import System.Nix.Build (BuildMode, BuildResult) import System.Nix.Derivation (Derivation) import System.Nix.DerivedPath (DerivedPath) import System.Nix.Hash (HashAlgo) -import System.Nix.Store.Types (RepairMode) +import System.Nix.Store.Types (FileIngestionMethod, RepairMode) import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.Types.CheckMode (CheckMode) @@ -31,7 +31,7 @@ data StoreRequest :: Type -> Type where -- | Add @NarSource@ to the store. AddToStore :: StorePathName -- ^ Name part of the newly created @StorePath@ - -> Bool -- ^ Add target directory recursively + -> FileIngestionMethod -- ^ Add target directory recursively -> Some HashAlgo -- ^ Nar hashing algorithm -- -> (forall m . MonadIO m => NarSource m) -- ^ provide nar stream -- Not part of StoreRequest From c3ece677b83f24e96ab442c62db5b2e8579d270d Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 14:53:19 +0100 Subject: [PATCH 019/104] core: add note that parseDerivedPath breaks when storeDir has exclamation mark --- hnix-store-core/src/System/Nix/DerivedPath.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/hnix-store-core/src/System/Nix/DerivedPath.hs b/hnix-store-core/src/System/Nix/DerivedPath.hs index df12e18..722e720 100644 --- a/hnix-store-core/src/System/Nix/DerivedPath.hs +++ b/hnix-store-core/src/System/Nix/DerivedPath.hs @@ -62,6 +62,7 @@ parseDerivedPath -> Text -> Either ParseOutputsError DerivedPath parseDerivedPath root p = + -- TODO: breaks when root contains ! case Data.Text.breakOn "!" p of (s, r) -> if Data.Text.null r From 91befa2a3cbe6c265a1b27576788644fad9a31d9 Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 18:40:51 +0100 Subject: [PATCH 020/104] core: fix parseDerivedPath breaking when StoreDir contains exclamation mark --- hnix-store-core/src/System/Nix/DerivedPath.hs | 40 ++++++++++++++----- hnix-store-tests/hnix-store-tests.cabal | 1 - hnix-store-tests/tests/DerivedPathSpec.hs | 7 ++-- 3 files changed, 32 insertions(+), 16 deletions(-) diff --git a/hnix-store-core/src/System/Nix/DerivedPath.hs b/hnix-store-core/src/System/Nix/DerivedPath.hs index 722e720..2e886ce 100644 --- a/hnix-store-core/src/System/Nix/DerivedPath.hs +++ b/hnix-store-core/src/System/Nix/DerivedPath.hs @@ -14,8 +14,9 @@ import Data.Bifunctor (first) import GHC.Generics (Generic) import Data.Set (Set) import Data.Text (Text) -import System.Nix.StorePath (StoreDir, StorePath, StorePathName, InvalidPathError) +import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, InvalidPathError) +import qualified Data.ByteString.Char8 import qualified Data.Set import qualified Data.Text import qualified System.Nix.StorePath @@ -33,6 +34,7 @@ data DerivedPath = data ParseOutputsError = ParseOutputsError_InvalidPath InvalidPathError | ParseOutputsError_NoNames + | ParseOutputsError_NoPrefix StoreDir Text deriving (Eq, Ord, Show) convertError @@ -61,16 +63,32 @@ parseDerivedPath :: StoreDir -> Text -> Either ParseOutputsError DerivedPath -parseDerivedPath root p = - -- TODO: breaks when root contains ! - case Data.Text.breakOn "!" p of - (s, r) -> - if Data.Text.null r - then DerivedPath_Opaque - <$> (convertError $ System.Nix.StorePath.parsePathFromText root s) - else DerivedPath_Built - <$> (convertError $ System.Nix.StorePath.parsePathFromText root s) - <*> parseOutputsSpec (Data.Text.drop (Data.Text.length "!") r) +parseDerivedPath root@(StoreDir sd) path = + let -- We need to do a bit more legwork for case + -- when StoreDir contains '!' + -- which is generated by its Arbitrary instance + textRoot = Data.Text.pack + $ Data.ByteString.Char8.unpack sd + + in case Data.Text.stripPrefix textRoot path of + Nothing -> Left $ ParseOutputsError_NoPrefix root path + Just woRoot -> + case Data.Text.breakOn "!" woRoot of + (pathNoPrefix, r) -> + if Data.Text.null r + then DerivedPath_Opaque + <$> (convertError + $ System.Nix.StorePath.parsePathFromText + root + path + ) + else DerivedPath_Built + <$> (convertError + $ System.Nix.StorePath.parsePathFromText + root + (textRoot <> pathNoPrefix) + ) + <*> parseOutputsSpec (Data.Text.drop (Data.Text.length "!") r) derivedPathToText :: StoreDir -> DerivedPath -> Text derivedPathToText root = \case diff --git a/hnix-store-tests/hnix-store-tests.cabal b/hnix-store-tests/hnix-store-tests.cabal index e975c98..e903261 100644 --- a/hnix-store-tests/hnix-store-tests.cabal +++ b/hnix-store-tests/hnix-store-tests.cabal @@ -81,7 +81,6 @@ test-suite props , hnix-store-tests , attoparsec , containers - , data-default-class , QuickCheck , text , hspec diff --git a/hnix-store-tests/tests/DerivedPathSpec.hs b/hnix-store-tests/tests/DerivedPathSpec.hs index f2a0b62..a80b49e 100644 --- a/hnix-store-tests/tests/DerivedPathSpec.hs +++ b/hnix-store-tests/tests/DerivedPathSpec.hs @@ -1,6 +1,5 @@ module DerivedPathSpec where -import Data.Default.Class (Default(def)) import Test.Hspec (Spec, describe, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary(arbitrary), forAll, suchThat) @@ -14,10 +13,10 @@ import qualified System.Nix.DerivedPath spec :: Spec spec = do describe "DerivedPath" $ do - prop "roundtrips" $ + prop "roundtrips" $ \sd -> forAll (arbitrary `suchThat` nonEmptyOutputsSpec_Names) $ \p -> - System.Nix.DerivedPath.parseDerivedPath def - (System.Nix.DerivedPath.derivedPathToText def p) + System.Nix.DerivedPath.parseDerivedPath sd + (System.Nix.DerivedPath.derivedPathToText sd p) `shouldBe` pure p where nonEmptyOutputsSpec_Names :: DerivedPath -> Bool From 4e224c3f430e9de564df5a02f9c2e1f37afb72da Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 19:19:28 +0100 Subject: [PATCH 021/104] tests: custom Arbitrary OutputsSpec producing nonempty OutputsSpec_Names --- hnix-store-tests/hnix-store-tests.cabal | 3 +-- .../src/System/Nix/Arbitrary/DerivedPath.hs | 14 ++++++++++---- hnix-store-tests/tests/DerivedPathSpec.hs | 18 +++++------------- 3 files changed, 16 insertions(+), 19 deletions(-) diff --git a/hnix-store-tests/hnix-store-tests.cabal b/hnix-store-tests/hnix-store-tests.cabal index e903261..1853071 100644 --- a/hnix-store-tests/hnix-store-tests.cabal +++ b/hnix-store-tests/hnix-store-tests.cabal @@ -51,6 +51,7 @@ library base >=4.12 && <5 , hnix-store-core >= 0.8 , bytestring + , containers , crypton , dependent-sum > 0.7 , generic-arbitrary < 1.1 @@ -80,7 +81,5 @@ test-suite props , hnix-store-core , hnix-store-tests , attoparsec - , containers - , QuickCheck , text , hspec diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs b/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs index 7ea7955..97918e3 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs @@ -3,13 +3,19 @@ {-# OPTIONS_GHC -Wno-orphans #-} module System.Nix.Arbitrary.DerivedPath where -import Test.QuickCheck (Arbitrary) +import qualified Data.Set +import Test.QuickCheck (Arbitrary(..), oneof) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) import System.Nix.Arbitrary.StorePath () -import System.Nix.DerivedPath (DerivedPath, OutputsSpec) +import System.Nix.DerivedPath (DerivedPath, OutputsSpec(..)) -deriving via GenericArbitrary OutputsSpec - instance Arbitrary OutputsSpec +instance Arbitrary OutputsSpec where + arbitrary = oneof + [ pure OutputsSpec_All + , OutputsSpec_Names + . Data.Set.fromList + <$> ((:) <$> arbitrary <*> arbitrary) + ] deriving via GenericArbitrary DerivedPath instance Arbitrary DerivedPath diff --git a/hnix-store-tests/tests/DerivedPathSpec.hs b/hnix-store-tests/tests/DerivedPathSpec.hs index a80b49e..7debac2 100644 --- a/hnix-store-tests/tests/DerivedPathSpec.hs +++ b/hnix-store-tests/tests/DerivedPathSpec.hs @@ -1,25 +1,17 @@ module DerivedPathSpec where -import Test.Hspec (Spec, describe, shouldBe) +import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Arbitrary(arbitrary), forAll, suchThat) +import Test.Hspec.Nix (roundtrips) import System.Nix.Arbitrary () -import System.Nix.DerivedPath (DerivedPath(..), OutputsSpec(..)) -import qualified Data.Set import qualified System.Nix.DerivedPath spec :: Spec spec = do describe "DerivedPath" $ do prop "roundtrips" $ \sd -> - forAll (arbitrary `suchThat` nonEmptyOutputsSpec_Names) $ \p -> - System.Nix.DerivedPath.parseDerivedPath sd - (System.Nix.DerivedPath.derivedPathToText sd p) - `shouldBe` pure p - where - nonEmptyOutputsSpec_Names :: DerivedPath -> Bool - nonEmptyOutputsSpec_Names (DerivedPath_Built _ (OutputsSpec_Names set)) = - not $ Data.Set.null set - nonEmptyOutputsSpec_Names _ = True + roundtrips + (System.Nix.DerivedPath.derivedPathToText sd) + (System.Nix.DerivedPath.parseDerivedPath sd) From 4ae2d827ada0f9823711e6f50b36fde97eea0ccf Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 14:54:03 +0100 Subject: [PATCH 022/104] remote: add storeRequest Serializer, property test --- .../src/System/Nix/Store/Remote/Serializer.hs | 230 +++++++++++++++++- hnix-store-remote/tests/NixSerializerSpec.hs | 20 +- 2 files changed, 248 insertions(+), 2 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 270931c..79354ce 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -69,6 +69,7 @@ module System.Nix.Store.Remote.Serializer -- * Worker protocol , storeText , workerOp + , storeRequest ) where import Control.Monad.Except (MonadError, throwError, ) @@ -84,7 +85,7 @@ import Data.Hashable (Hashable) import Data.HashSet (HashSet) import Data.Map (Map) import Data.Set (Set) -import Data.Some (Some) +import Data.Some (Some(Some)) import Data.Text (Text) import Data.Time (NominalDiffTime, UTCTime) import Data.Vector (Vector) @@ -942,3 +943,230 @@ storeText = Serializer workerOp :: NixSerializer r SError WorkerOp workerOp = enum +storeRequest + :: ( HasProtoVersion r + , HasStoreDir r + ) + => NixSerializer r SError (Some StoreRequest) +storeRequest = Serializer + { getS = getS workerOp >>= \case + WorkerOp_AddToStore -> do + pathName <- getS storePathName + recursive <- getS enum + hashAlgo <- getS someHashAlgo + repairMode <- getS enum + pure $ Some (AddToStore pathName recursive hashAlgo repairMode) + + WorkerOp_AddTextToStore -> do + txt <- getS storeText + paths <- getS (hashSet storePath) + repairMode <- getS enum + pure $ Some (AddTextToStore txt paths repairMode) + + WorkerOp_AddSignatures -> do + path <- getS storePath + signatures <- getS (list byteString) + pure $ Some (AddSignatures path signatures) + + WorkerOp_AddIndirectRoot -> + Some . AddIndirectRoot <$> getS storePath + + WorkerOp_AddTempRoot -> + Some . AddTempRoot <$> getS storePath + + WorkerOp_BuildPaths -> do + derived <- getS (set derivedPath) + buildMode' <- getS buildMode + pure $ Some (BuildPaths derived buildMode') + + WorkerOp_BuildDerivation -> do + path <- getS storePath + drv <- getS derivation + buildMode' <- getS buildMode + pure $ Some (BuildDerivation path drv buildMode') + + WorkerOp_EnsurePath -> + Some . EnsurePath <$> getS storePath + + WorkerOp_FindRoots -> do + pure $ Some FindRoots + + WorkerOp_IsValidPath -> + Some . IsValidPath <$> getS storePath + + WorkerOp_QueryValidPaths -> do + paths <- getS (hashSet storePath) + substituteMode <- getS enum + pure $ Some (QueryValidPaths paths substituteMode) + + WorkerOp_QueryAllValidPaths -> + pure $ Some QueryAllValidPaths + + WorkerOp_QuerySubstitutablePaths -> + Some . QuerySubstitutablePaths <$> getS (hashSet storePath) + + WorkerOp_QueryPathInfo -> + Some . QueryPathInfo <$> getS storePath + + WorkerOp_QueryReferrers -> + Some . QueryReferrers <$> getS storePath + + WorkerOp_QueryValidDerivers -> + Some . QueryValidDerivers <$> getS storePath + + WorkerOp_QueryDerivationOutputs -> + Some . QueryDerivationOutputs <$> getS storePath + + WorkerOp_QueryDerivationOutputNames -> + Some . QueryDerivationOutputNames <$> getS storePath + + WorkerOp_QueryPathFromHashPart -> + Some . QueryPathFromHashPart <$> getS storePathHashPart + + WorkerOp_QueryMissing -> + Some . QueryMissing <$> getS (set derivedPath) + + WorkerOp_OptimiseStore -> + pure $ Some OptimiseStore + + WorkerOp_SyncWithGC -> + pure $ Some SyncWithGC + + WorkerOp_VerifyStore -> do + checkMode <- getS enum + repairMode <- getS enum + + pure $ Some (VerifyStore checkMode repairMode) + + WorkerOp_Reserved_0__ -> undefined + WorkerOp_Reserved_2__ -> undefined + WorkerOp_Reserved_15__ -> undefined + WorkerOp_Reserved_17__ -> undefined + + WorkerOp_AddBuildLog -> undefined + WorkerOp_AddMultipleToStore -> undefined + WorkerOp_AddToStoreNar -> undefined + WorkerOp_BuildPathsWithResults -> undefined + WorkerOp_ClearFailedPaths -> undefined + WorkerOp_CollectGarbage -> undefined + WorkerOp_ExportPath -> undefined + WorkerOp_HasSubstitutes -> undefined + WorkerOp_ImportPaths -> undefined + WorkerOp_NarFromPath -> undefined + WorkerOp_QueryDerivationOutputMap -> undefined + WorkerOp_QueryDeriver -> undefined + WorkerOp_QueryFailedPaths -> undefined + WorkerOp_QueryPathHash -> undefined + WorkerOp_QueryRealisation -> undefined + WorkerOp_QuerySubstitutablePathInfo -> undefined + WorkerOp_QuerySubstitutablePathInfos -> undefined + WorkerOp_QueryReferences -> undefined + WorkerOp_RegisterDrvOutput -> undefined + WorkerOp_SetOptions -> undefined + + , putS = \case + Some (AddToStore pathName recursive hashAlgo repairMode) -> do + putS workerOp WorkerOp_AddToStore + + putS storePathName pathName + putS enum recursive + putS someHashAlgo hashAlgo + putS enum repairMode + + Some (AddTextToStore txt paths repairMode) -> do + putS workerOp WorkerOp_AddTextToStore + + putS storeText txt + putS (hashSet storePath) paths + putS enum repairMode + + Some (AddSignatures path signatures) -> do + putS workerOp WorkerOp_AddSignatures + + putS storePath path + putS (list byteString) signatures + + Some (AddIndirectRoot path) -> do + putS workerOp WorkerOp_AddIndirectRoot + putS storePath path + + Some (AddTempRoot path) -> do + putS workerOp WorkerOp_AddTempRoot + putS storePath path + + Some (BuildPaths derived buildMode') -> do + putS workerOp WorkerOp_BuildPaths + + putS (set derivedPath) derived + putS buildMode buildMode' + + Some (BuildDerivation path drv buildMode') -> do + putS workerOp WorkerOp_BuildDerivation + + putS storePath path + putS derivation drv + putS buildMode buildMode' + + Some (EnsurePath path) -> do + putS workerOp WorkerOp_EnsurePath + putS storePath path + + Some FindRoots -> + putS workerOp WorkerOp_FindRoots + + Some (IsValidPath path) -> do + putS workerOp WorkerOp_IsValidPath + putS storePath path + + Some (QueryValidPaths paths substituteMode) -> do + putS workerOp WorkerOp_QueryValidPaths + + putS (hashSet storePath) paths + putS enum substituteMode + + Some QueryAllValidPaths -> + putS workerOp WorkerOp_QueryAllValidPaths + + Some (QuerySubstitutablePaths paths) -> do + putS workerOp WorkerOp_QuerySubstitutablePaths + putS (hashSet storePath) paths + + Some (QueryPathInfo path) -> do + putS workerOp WorkerOp_QueryPathInfo + putS storePath path + + Some (QueryReferrers path) -> do + putS workerOp WorkerOp_QueryReferrers + putS storePath path + + Some (QueryValidDerivers path) -> do + putS workerOp WorkerOp_QueryValidDerivers + putS storePath path + + Some (QueryDerivationOutputs path) -> do + putS workerOp WorkerOp_QueryDerivationOutputs + putS storePath path + + Some (QueryDerivationOutputNames path) -> do + putS workerOp WorkerOp_QueryDerivationOutputNames + putS storePath path + + Some (QueryPathFromHashPart pathHashPart) -> do + putS workerOp WorkerOp_QueryPathFromHashPart + putS storePathHashPart pathHashPart + + Some (QueryMissing derived) -> do + putS workerOp WorkerOp_QueryMissing + putS (set derivedPath) derived + + Some OptimiseStore -> + putS workerOp WorkerOp_OptimiseStore + + Some SyncWithGC -> + putS workerOp WorkerOp_SyncWithGC + + Some (VerifyStore checkMode repairMode) -> do + putS workerOp WorkerOp_VerifyStore + putS enum checkMode + putS enum repairMode + } diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 5d1918d..df3c154 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -24,7 +24,14 @@ import System.Nix.StorePath (StoreDir) import System.Nix.StorePath.Metadata (Metadata(..)) import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serializer -import System.Nix.Store.Remote.Types (ErrorInfo(..), Logger(..), ProtoVersion(..), Trace(..), WorkerOp(..)) +import System.Nix.Store.Remote.Types.Logger (ErrorInfo(..), Logger(..), Trace(..)) +import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..)) +import System.Nix.Store.Remote.Types.StoreConfig (TestStoreConfig) +import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp(..)) + +-- WIP +import Data.Some (Some(Some)) +import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) -- | Test for roundtrip using @NixSerializer@ roundtripSReader @@ -170,6 +177,17 @@ spec = parallel $ do describe "Worker protocol" $ do prop "StoreText" $ roundtripS storeText + prop "StoreRequest" + $ \testStoreConfig -> + forAll (arbitrary `suchThat` (hacks (hasProtoVersion testStoreConfig))) + $ roundtripSReader @TestStoreConfig storeRequest testStoreConfig + +hacks :: ProtoVersion -> Some StoreRequest -> Bool +hacks v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False +hacks _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty +hacks v (Some (QueryMissing _)) | v < ProtoVersion 1 30 = False +hacks _ _ = True + errorInfoIf :: Bool -> Logger -> Bool errorInfoIf True (Logger_Error (Right x)) = noJust0s x where From 6c0edf2fcf14eb78bb3a72f8f64cda94fb44e2d8 Mon Sep 17 00:00:00 2001 From: sorki Date: Fri, 1 Dec 2023 15:18:04 +0100 Subject: [PATCH 023/104] remote: drop dependent-sum upper bound like in core --- hnix-store-remote/hnix-store-remote.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 53953f7..8db035f 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -107,7 +107,7 @@ library , containers , crypton , data-default-class - , dependent-sum > 0.7 && < 1 + , dependent-sum > 0.7 , dependent-sum-template > 0.1.1 && < 0.3 , generic-arbitrary < 1.1 , hashable @@ -169,7 +169,7 @@ test-suite remote , hnix-store-tests , cereal , crypton - , dependent-sum > 0.7 && < 1 + , dependent-sum > 0.7 , some > 1.0.5 && < 2 , text , time From cc931dde1e44901207afd3d4cd6f1aa6b0a16ce7 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 10:03:16 +0100 Subject: [PATCH 024/104] tests: custom Arbitrary UTCTime instance, drop quickcheck-instances in favor of our own small set of required instances. --- hnix-store-remote/hnix-store-remote.cabal | 2 -- .../src/System/Nix/Store/Remote/Arbitrary.hs | 1 - hnix-store-remote/tests/NixSerializerSpec.hs | 31 ++----------------- hnix-store-remote/tests/SerializeSpec.hs | 25 ++------------- hnix-store-tests/hnix-store-tests.cabal | 12 +++++-- .../src/Data/ByteString/Arbitrary.hs | 10 ++++++ .../src/Data/HashSet/Arbitrary.hs | 11 +++++++ hnix-store-tests/src/Data/Text/Arbitrary.hs | 10 ++++++ hnix-store-tests/src/Data/Vector/Arbitrary.hs | 20 ++++++++++++ hnix-store-tests/src/System/Nix/Arbitrary.hs | 5 +++ .../src/System/Nix/Arbitrary/Base.hs | 1 - .../src/System/Nix/Arbitrary/Build.hs | 7 +++-- .../src/System/Nix/Arbitrary/Derivation.hs | 3 +- .../src/System/Nix/Arbitrary/Hash.hs | 2 +- .../src/System/Nix/Arbitrary/Signature.hs | 1 - .../Nix/Arbitrary/StorePath/Metadata.hs | 3 +- .../src/System/Nix/Arbitrary/UTCTime.hs | 26 ++++++++++++++++ 17 files changed, 106 insertions(+), 64 deletions(-) create mode 100644 hnix-store-tests/src/Data/ByteString/Arbitrary.hs create mode 100644 hnix-store-tests/src/Data/HashSet/Arbitrary.hs create mode 100644 hnix-store-tests/src/Data/Text/Arbitrary.hs create mode 100644 hnix-store-tests/src/Data/Vector/Arbitrary.hs create mode 100644 hnix-store-tests/src/System/Nix/Arbitrary/UTCTime.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 8db035f..2a85021 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -117,7 +117,6 @@ library , network , mtl , QuickCheck - , quickcheck-instances , unordered-containers , vector hs-source-dirs: src @@ -175,7 +174,6 @@ test-suite remote , time , hspec , QuickCheck - , quickcheck-instances , unordered-containers test-suite remote-io diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index 485d0df..4a1c5e4 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -9,7 +9,6 @@ import System.Nix.Store.Remote.Types import Test.QuickCheck (Arbitrary(..), oneof) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) -import Test.QuickCheck.Instances () deriving via GenericArbitrary CheckMode instance Arbitrary CheckMode diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index df3c154..9e8811a 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -4,21 +4,16 @@ module NixSerializerSpec (spec) where import Crypto.Hash (MD5, SHA1, SHA256, SHA512) import Data.Dependent.Sum (DSum((:=>))) -import Data.Fixed (Uni) -import Data.Time (NominalDiffTime) +import Data.Time (UTCTime) import Data.Word (Word64) import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, arbitrary, forAll, suchThat) -import Test.QuickCheck.Instances () -import qualified Data.Time.Clock.POSIX -import qualified Data.Serializer import qualified System.Nix.Build import qualified System.Nix.Hash import System.Nix.Arbitrary () -import System.Nix.Build (BuildResult) import System.Nix.Derivation (Derivation(inputDrvs)) import System.Nix.StorePath (StoreDir) import System.Nix.StorePath.Metadata (Metadata(..)) @@ -71,19 +66,7 @@ spec = parallel $ do prop "Maybe Text" $ forAll (arbitrary `suchThat` (/= Just "")) $ roundtripS maybeText - prop "UTCTime" $ do - let - -- scale to seconds and back - toSeconds :: Int -> NominalDiffTime - toSeconds n = realToFrac (toEnum n :: Uni) - fromSeconds :: NominalDiffTime -> Int - fromSeconds = (fromEnum :: Uni -> Int) . realToFrac - - roundtripS @Int @() $ - Data.Serializer.mapIsoSerializer - (fromSeconds . Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds) - (Data.Time.Clock.POSIX.posixSecondsToUTCTime . toSeconds) - time + prop "UTCTime" $ roundtripS @UTCTime @() time describe "Combinators" $ do prop "list" $ roundtripS @[Int] @() (list int) @@ -94,12 +77,7 @@ spec = parallel $ do describe "Complex" $ do prop "BuildResult" $ forAll (arbitrary `suchThat` ((/= Just "") . System.Nix.Build.errorMessage)) - $ \br -> - roundtripS @BuildResult buildResult - -- fix time to 0 as we test UTCTime above - $ br { System.Nix.Build.startTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 - , System.Nix.Build.stopTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 - } + $ roundtripS buildResult prop "StorePath" $ roundtripSReader @StoreDir storePath @@ -118,9 +96,6 @@ spec = parallel $ do prop "Metadata (StorePath)" $ \sd -> forAll (arbitrary `suchThat` (\m -> narHashIsSHA256 m && narBytes m /= Just 0)) $ roundtripSReader @StoreDir pathMetadata sd - . (\m -> m - { registrationTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 - }) prop "Some HashAlgo" $ roundtripS someHashAlgo diff --git a/hnix-store-remote/tests/SerializeSpec.hs b/hnix-store-remote/tests/SerializeSpec.hs index 4b9c1d4..5de2791 100644 --- a/hnix-store-remote/tests/SerializeSpec.hs +++ b/hnix-store-remote/tests/SerializeSpec.hs @@ -2,25 +2,21 @@ module SerializeSpec (spec) where -import Data.Fixed (Uni) import Data.Serialize (Serialize(..)) import Data.Serialize.Get (Get, runGet) import Data.Serialize.Put (Putter, runPut) import Data.Text (Text) -import Data.Time (NominalDiffTime) import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.Hspec.Nix (roundtrips) import Test.QuickCheck (arbitrary, forAll, suchThat) -import Test.QuickCheck.Instances () import qualified Data.Either import qualified Data.HashSet -import qualified Data.Time.Clock.POSIX import qualified System.Nix.Build import System.Nix.Arbitrary () -import System.Nix.Build (BuildMode(..), BuildStatus(..)) +import System.Nix.Build (BuildMode(..), BuildResult, BuildStatus(..)) import System.Nix.Derivation (Derivation(inputDrvs)) import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serialize (getDerivation, putDerivation) @@ -61,18 +57,6 @@ spec = parallel $ do prop "Bool" $ roundtrips2 putBool getBool prop "ByteString" $ roundtrips2 putByteString getByteString - prop "UTCTime" $ do - let - -- scale to seconds and back - toSeconds :: Int -> NominalDiffTime - toSeconds n = realToFrac (toEnum n :: Uni) - fromSeconds :: NominalDiffTime -> Int - fromSeconds = (fromEnum :: Uni -> Int) . realToFrac - - roundtrips2 - (putTime . Data.Time.Clock.POSIX.posixSecondsToUTCTime . toSeconds) - (fromSeconds . Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds <$> getTime) - describe "Combinators" $ do prop "Many" $ roundtrips2 (putMany putInt) (getMany (getInt @Int)) prop "[ByteString]" $ roundtrips2 putByteStrings getByteStrings @@ -95,12 +79,7 @@ spec = parallel $ do prop "BuildStatus" $ roundtripS @BuildStatus it "BuildResult" $ forAll (arbitrary `suchThat` ((/= Just "") . System.Nix.Build.errorMessage)) - $ \br -> - roundtripS - -- fix time to 0 as we test UTCTime above - $ br { System.Nix.Build.startTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 - , System.Nix.Build.stopTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 - } + $ roundtripS @BuildResult prop "ProtoVersion" $ roundtripS @ProtoVersion diff --git a/hnix-store-tests/hnix-store-tests.cabal b/hnix-store-tests/hnix-store-tests.cabal index 1853071..a6a3f97 100644 --- a/hnix-store-tests/hnix-store-tests.cabal +++ b/hnix-store-tests/hnix-store-tests.cabal @@ -35,7 +35,11 @@ common commons library import: commons exposed-modules: - System.Nix.Arbitrary + Data.ByteString.Arbitrary + , Data.HashSet.Arbitrary + , Data.Text.Arbitrary + , Data.Vector.Arbitrary + , System.Nix.Arbitrary , System.Nix.Arbitrary.Base , System.Nix.Arbitrary.Build , System.Nix.Arbitrary.ContentAddress @@ -46,6 +50,7 @@ library , System.Nix.Arbitrary.Store.Types , System.Nix.Arbitrary.StorePath , System.Nix.Arbitrary.StorePath.Metadata + , System.Nix.Arbitrary.UTCTime , Test.Hspec.Nix build-depends: base >=4.12 && <5 @@ -55,10 +60,13 @@ library , crypton , dependent-sum > 0.7 , generic-arbitrary < 1.1 + , hashable , hspec , QuickCheck - , quickcheck-instances , text + , time + , unordered-containers + , vector hs-source-dirs: src test-suite props diff --git a/hnix-store-tests/src/Data/ByteString/Arbitrary.hs b/hnix-store-tests/src/Data/ByteString/Arbitrary.hs new file mode 100644 index 0000000..0024800 --- /dev/null +++ b/hnix-store-tests/src/Data/ByteString/Arbitrary.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Data.ByteString.Arbitrary () where + +import Data.ByteString (ByteString) +import Test.QuickCheck (Arbitrary(..)) +import qualified Data.ByteString.Char8 + +instance Arbitrary ByteString where + arbitrary = Data.ByteString.Char8.pack <$> arbitrary + shrink xs = Data.ByteString.Char8.pack <$> shrink (Data.ByteString.Char8.unpack xs) diff --git a/hnix-store-tests/src/Data/HashSet/Arbitrary.hs b/hnix-store-tests/src/Data/HashSet/Arbitrary.hs new file mode 100644 index 0000000..a992a5a --- /dev/null +++ b/hnix-store-tests/src/Data/HashSet/Arbitrary.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.HashSet.Arbitrary where + +import Data.Hashable (Hashable) +import Data.HashSet (HashSet) +import Test.QuickCheck (Arbitrary(..)) +import qualified Data.HashSet + +instance (Hashable a, Eq a, Arbitrary a) => Arbitrary (HashSet a) where + arbitrary = Data.HashSet.fromList <$> arbitrary + shrink hashset = Data.HashSet.fromList <$> shrink (Data.HashSet.toList hashset) diff --git a/hnix-store-tests/src/Data/Text/Arbitrary.hs b/hnix-store-tests/src/Data/Text/Arbitrary.hs new file mode 100644 index 0000000..685f8f6 --- /dev/null +++ b/hnix-store-tests/src/Data/Text/Arbitrary.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Data.Text.Arbitrary () where + +import Data.Text (Text) +import Test.QuickCheck (Arbitrary(..)) +import qualified Data.Text + +instance Arbitrary Text where + arbitrary = Data.Text.pack <$> arbitrary + shrink xs = Data.Text.pack <$> shrink (Data.Text.unpack xs) diff --git a/hnix-store-tests/src/Data/Vector/Arbitrary.hs b/hnix-store-tests/src/Data/Vector/Arbitrary.hs new file mode 100644 index 0000000..0d006dc --- /dev/null +++ b/hnix-store-tests/src/Data/Vector/Arbitrary.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +-- Stolen from quickcheck-instances (BSD-3) +module Data.Vector.Arbitrary () where + +import Data.Vector (Vector) +import Test.QuickCheck (Arbitrary(..), Arbitrary1(..), arbitrary1, shrink1) +import qualified Data.Vector + +instance Arbitrary1 Vector where + liftArbitrary = + fmap Data.Vector.fromList + . liftArbitrary + liftShrink shr = + fmap Data.Vector.fromList + . liftShrink shr + . Data.Vector.toList + +instance Arbitrary a => Arbitrary (Vector a) where + arbitrary = arbitrary1 + shrink = shrink1 diff --git a/hnix-store-tests/src/System/Nix/Arbitrary.hs b/hnix-store-tests/src/System/Nix/Arbitrary.hs index 4d2f5b5..e5020c5 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary.hs @@ -1,5 +1,10 @@ module System.Nix.Arbitrary where +import Data.ByteString.Arbitrary () +import Data.HashSet.Arbitrary () +import Data.Text.Arbitrary () +import Data.Vector.Arbitrary () + import System.Nix.Arbitrary.Base () import System.Nix.Arbitrary.Build () import System.Nix.Arbitrary.ContentAddress () diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Base.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Base.hs index 0f89ad2..0a24e07 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Base.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Base.hs @@ -7,7 +7,6 @@ import System.Nix.Base import Test.QuickCheck (Arbitrary(..)) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) -import Test.QuickCheck.Instances () deriving via GenericArbitrary BaseEncoding instance Arbitrary BaseEncoding diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs index 3052ec9..1a802ca 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs @@ -3,11 +3,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} module System.Nix.Arbitrary.Build where -import System.Nix.Build - +import Data.Text.Arbitrary () import Test.QuickCheck (Arbitrary(..)) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) -import Test.QuickCheck.Instances () +import System.Nix.Arbitrary.UTCTime () + +import System.Nix.Build deriving via GenericArbitrary BuildMode instance Arbitrary BuildMode diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs index 4d9b567..9910dee 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs @@ -4,12 +4,13 @@ module System.Nix.Arbitrary.Derivation where import Data.Text (Text) +import Data.Text.Arbitrary () +import Data.Vector.Arbitrary () import System.Nix.Derivation import System.Nix.StorePath (StorePath) import Test.QuickCheck (Arbitrary(..)) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) -import Test.QuickCheck.Instances () import System.Nix.Arbitrary.StorePath () deriving via GenericArbitrary (Derivation StorePath Text) diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs index b959d33..ad9b308 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs @@ -4,13 +4,13 @@ module System.Nix.Arbitrary.Hash where import Data.ByteString (ByteString) +import Data.ByteString.Arbitrary () import Crypto.Hash (Digest, MD5(..), SHA1(..), SHA256(..), SHA512(..)) import Data.Dependent.Sum (DSum((:=>))) import Data.Some (Some(Some)) import System.Nix.Hash (HashAlgo(..)) import Test.QuickCheck (Arbitrary(arbitrary), oneof) -import Test.QuickCheck.Instances () import qualified Crypto.Hash diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs index 17520c3..b11f9ae 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs @@ -9,7 +9,6 @@ import Crypto.Random (drgNewTest, withDRG) import qualified Data.ByteString as BS import qualified Data.Text as Text import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) -import Test.QuickCheck.Instances () import Test.QuickCheck import System.Nix.Signature diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs index 8ce25f0..60aae88 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs @@ -4,16 +4,17 @@ {-# OPTIONS_GHC -Wno-orphans #-} module System.Nix.Arbitrary.StorePath.Metadata where +import Data.HashSet.Arbitrary () import System.Nix.Arbitrary.ContentAddress () import System.Nix.Arbitrary.Hash () import System.Nix.Arbitrary.Signature () import System.Nix.Arbitrary.StorePath () +import System.Nix.Arbitrary.UTCTime () import System.Nix.StorePath (StorePath) import System.Nix.StorePath.Metadata (Metadata, StorePathTrust) import Test.QuickCheck (Arbitrary(..)) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) -import Test.QuickCheck.Instances () deriving via GenericArbitrary StorePathTrust instance Arbitrary StorePathTrust diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/UTCTime.hs b/hnix-store-tests/src/System/Nix/Arbitrary/UTCTime.hs new file mode 100644 index 0000000..8eb3337 --- /dev/null +++ b/hnix-store-tests/src/System/Nix/Arbitrary/UTCTime.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +-- Stolen from quickcheck-instances (BSD-3) +-- UTCTime/DiffTime slightly modified to produce +-- values rounded to whole seconds +module System.Nix.Arbitrary.UTCTime where + +import Data.Time (Day(..), DiffTime, UTCTime(..)) +import Test.QuickCheck (Arbitrary(..)) + +instance Arbitrary Day where + arbitrary = ModifiedJulianDay <$> (2000 +) <$> arbitrary + shrink = (ModifiedJulianDay <$>) . shrink . Data.Time.toModifiedJulianDay + +instance Arbitrary DiffTime where + -- without abs something weird happens, try it + arbitrary = fromInteger . abs <$> arbitrary + +instance Arbitrary UTCTime where + arbitrary = + UTCTime + <$> arbitrary + <*> arbitrary + shrink ut@(UTCTime day dayTime) = + [ ut { Data.Time.utctDay = d' } | d' <- shrink day ] + ++ [ ut { Data.Time.utctDayTime = t' } | t' <- shrink dayTime ] + From a7fbcf7a02d6b79bf642d40641a1238ed8f3033a Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 11:43:47 +0100 Subject: [PATCH 025/104] tests: custom Arbitrary BuildResult without Just mempty errorMessage --- hnix-store-remote/tests/NixSerializerSpec.hs | 5 +---- hnix-store-remote/tests/SerializeSpec.hs | 5 +---- .../src/System/Nix/Arbitrary/Build.hs | 15 ++++++++++++--- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 9e8811a..9a686bf 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -10,7 +10,6 @@ import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, arbitrary, forAll, suchThat) -import qualified System.Nix.Build import qualified System.Nix.Hash import System.Nix.Arbitrary () @@ -75,9 +74,7 @@ spec = parallel $ do prop "mapS" $ roundtripS (mapS (int @Int) byteString) describe "Complex" $ do - prop "BuildResult" - $ forAll (arbitrary `suchThat` ((/= Just "") . System.Nix.Build.errorMessage)) - $ roundtripS buildResult + prop "BuildResult" $ roundtripS buildResult prop "StorePath" $ roundtripSReader @StoreDir storePath diff --git a/hnix-store-remote/tests/SerializeSpec.hs b/hnix-store-remote/tests/SerializeSpec.hs index 5de2791..9526b2a 100644 --- a/hnix-store-remote/tests/SerializeSpec.hs +++ b/hnix-store-remote/tests/SerializeSpec.hs @@ -13,7 +13,6 @@ import Test.QuickCheck (arbitrary, forAll, suchThat) import qualified Data.Either import qualified Data.HashSet -import qualified System.Nix.Build import System.Nix.Arbitrary () import System.Nix.Build (BuildMode(..), BuildResult, BuildStatus(..)) @@ -77,9 +76,7 @@ spec = parallel $ do prop "Text" $ roundtripS @Text prop "BuildMode" $ roundtripS @BuildMode prop "BuildStatus" $ roundtripS @BuildStatus - it "BuildResult" $ - forAll (arbitrary `suchThat` ((/= Just "") . System.Nix.Build.errorMessage)) - $ roundtripS @BuildResult + prop "BuildResult" $ roundtripS @BuildResult prop "ProtoVersion" $ roundtripS @ProtoVersion diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs index 1a802ca..3ab100d 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs @@ -4,7 +4,7 @@ module System.Nix.Arbitrary.Build where import Data.Text.Arbitrary () -import Test.QuickCheck (Arbitrary(..)) +import Test.QuickCheck (Arbitrary(..), suchThat) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) import System.Nix.Arbitrary.UTCTime () @@ -16,5 +16,14 @@ deriving via GenericArbitrary BuildMode deriving via GenericArbitrary BuildStatus instance Arbitrary BuildStatus -deriving via GenericArbitrary BuildResult - instance Arbitrary BuildResult +instance Arbitrary BuildResult where + arbitrary = do + status <- arbitrary + -- we encode empty errorMessage as Nothing + errorMessage <- arbitrary `suchThat` (/= Just mempty) + timesBuilt <- arbitrary + isNonDeterministic <- arbitrary + startTime <- arbitrary + stopTime <- arbitrary + + pure $ BuildResult{..} From c815068e60b014b47d23607f84788192869d0ea0 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 12:49:42 +0100 Subject: [PATCH 026/104] tests: add custom Arbitrary (Maybe Text) that doesn't generate Just mempty --- hnix-store-remote/tests/NixSerializerSpec.hs | 4 +--- hnix-store-tests/src/Data/Text/Arbitrary.hs | 8 +++++++- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 9a686bf..154593f 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -62,9 +62,7 @@ spec = parallel $ do prop "Bool" $ roundtripS bool prop "ByteString" $ roundtripS byteString prop "Text" $ roundtripS text - prop "Maybe Text" - $ forAll (arbitrary `suchThat` (/= Just "")) - $ roundtripS maybeText + prop "Maybe Text" $ roundtripS maybeText prop "UTCTime" $ roundtripS @UTCTime @() time describe "Combinators" $ do diff --git a/hnix-store-tests/src/Data/Text/Arbitrary.hs b/hnix-store-tests/src/Data/Text/Arbitrary.hs index 685f8f6..34cba8e 100644 --- a/hnix-store-tests/src/Data/Text/Arbitrary.hs +++ b/hnix-store-tests/src/Data/Text/Arbitrary.hs @@ -2,9 +2,15 @@ module Data.Text.Arbitrary () where import Data.Text (Text) -import Test.QuickCheck (Arbitrary(..)) +import Test.QuickCheck (Arbitrary(..), frequency, suchThat) import qualified Data.Text instance Arbitrary Text where arbitrary = Data.Text.pack <$> arbitrary shrink xs = Data.Text.pack <$> shrink (Data.Text.unpack xs) + +instance {-# OVERLAPPING #-} Arbitrary (Maybe Text) where + arbitrary = frequency + [ (1, pure Nothing) + , (3, Just <$> arbitrary `suchThat` (/= mempty)) + ] From 9fb78545419c820e042baa105c20432fb78f6cf2 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 13:05:04 +0100 Subject: [PATCH 027/104] tests: custom Arbitrary Trace and Arbitrary ErrorInfo w/o (Just 0) --- .../src/System/Nix/Store/Remote/Arbitrary.hs | 22 ++++++++++++++---- hnix-store-remote/tests/NixSerializerSpec.hs | 23 ++++--------------- hnix-store-remote/tests/SerializeSpec.hs | 15 ++---------- 3 files changed, 23 insertions(+), 37 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index 4a1c5e4..50ee94d 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -7,7 +7,7 @@ import Data.Some (Some(Some)) import System.Nix.Arbitrary () import System.Nix.Store.Remote.Types -import Test.QuickCheck (Arbitrary(..), oneof) +import Test.QuickCheck (Arbitrary(..), oneof, suchThat) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) deriving via GenericArbitrary CheckMode @@ -39,14 +39,26 @@ deriving via GenericArbitrary ActivityResult deriving via GenericArbitrary Field instance Arbitrary Field -deriving via GenericArbitrary Trace - instance Arbitrary Trace +instance Arbitrary Trace where + arbitrary = do + -- we encode 0 position as Nothing + tracePosition <- arbitrary `suchThat` (/= Just 0) + traceHint <- arbitrary + + pure Trace{..} deriving via GenericArbitrary BasicError instance Arbitrary BasicError -deriving via GenericArbitrary ErrorInfo - instance Arbitrary ErrorInfo +instance Arbitrary ErrorInfo where + arbitrary = do + errorInfoLevel <- arbitrary + errorInfoMessage <- arbitrary + -- we encode 0 position as Nothing + errorInfoPosition <- arbitrary `suchThat` (/= Just 0) + errorInfoTraces <- arbitrary + + pure ErrorInfo{..} deriving via GenericArbitrary LoggerOpCode instance Arbitrary LoggerOpCode diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 154593f..c257abf 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -18,7 +18,7 @@ import System.Nix.StorePath (StoreDir) import System.Nix.StorePath.Metadata (Metadata(..)) import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serializer -import System.Nix.Store.Remote.Types.Logger (ErrorInfo(..), Logger(..), Trace(..)) +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.WorkerOp (WorkerOp(..)) @@ -112,19 +112,9 @@ spec = parallel $ do prop "Maybe Activity" $ roundtripS maybeActivity prop "ActivityResult" $ roundtripS activityResult prop "Field" $ roundtripS field - prop "Trace" - $ forAll (arbitrary `suchThat` ((/= Just 0) . tracePosition)) - $ roundtripS trace + prop "Trace" $ roundtripS trace prop "BasicError" $ roundtripS basicError - prop "ErrorInfo" - $ forAll (arbitrary - `suchThat` - (\ErrorInfo{..} - -> errorInfoPosition /= Just 0 - && all ((/= Just 0) . tracePosition) errorInfoTraces - ) - ) - $ roundtripS errorInfo + prop "ErrorInfo" $ roundtripS errorInfo prop "LoggerOpCode" $ roundtripS loggerOpCode prop "Verbosity" $ roundtripS verbosity prop "Logger" @@ -159,12 +149,7 @@ hacks v (Some (QueryMissing _)) | v < ProtoVersion 1 30 = False hacks _ _ = True errorInfoIf :: Bool -> Logger -> Bool -errorInfoIf True (Logger_Error (Right x)) = noJust0s x - where - noJust0s :: ErrorInfo -> Bool - noJust0s ErrorInfo{..} = - errorInfoPosition /= Just 0 - && all ((/= Just 0) . tracePosition) errorInfoTraces +errorInfoIf True (Logger_Error (Right _)) = True errorInfoIf False (Logger_Error (Left _)) = True errorInfoIf _ (Logger_Error _) = False errorInfoIf _ _ = True diff --git a/hnix-store-remote/tests/SerializeSpec.hs b/hnix-store-remote/tests/SerializeSpec.hs index 9526b2a..51502e6 100644 --- a/hnix-store-remote/tests/SerializeSpec.hs +++ b/hnix-store-remote/tests/SerializeSpec.hs @@ -9,7 +9,6 @@ import Data.Text (Text) import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.Hspec.Nix (roundtrips) -import Test.QuickCheck (arbitrary, forAll, suchThat) import qualified Data.Either import qualified Data.HashSet @@ -92,19 +91,9 @@ spec = parallel $ do prop "ActivityID" $ roundtripS @ActivityID prop "Activity" $ roundtripS @Activity prop "Field" $ roundtripS @Field - prop "Trace" - $ forAll (arbitrary `suchThat` ((/= Just 0) . tracePosition)) - $ roundtripS @Trace + prop "Trace" $ roundtripS @Trace prop "BasicError" $ roundtripS @BasicError - prop "ErrorInfo" - $ forAll (arbitrary - `suchThat` - (\ErrorInfo{..} - -> errorInfoPosition /= Just 0 - && all ((/= Just 0) . tracePosition) errorInfoTraces - ) - ) - $ roundtripS @ErrorInfo + prop "ErrorInfo" $ roundtripS @ErrorInfo prop "LoggerOpCode" $ roundtripS @LoggerOpCode prop "Verbosity" $ roundtripS @Verbosity From d8df1cccfd2314d7a91be092bba6f0d93b6f16e2 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 13:34:02 +0100 Subject: [PATCH 028/104] remote: no more hacks for StoreRequest prop --- hnix-store-remote/tests/NixSerializerSpec.hs | 26 +++++++++----------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index c257abf..0021b7c 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -4,6 +4,7 @@ module NixSerializerSpec (spec) where import Crypto.Hash (MD5, SHA1, SHA256, SHA512) import Data.Dependent.Sum (DSum((:=>))) +import Data.Some (Some(Some)) import Data.Time (UTCTime) import Data.Word (Word64) import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe) @@ -21,11 +22,8 @@ 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.WorkerOp (WorkerOp(..)) - --- WIP -import Data.Some (Some(Some)) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) +import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp(..)) -- | Test for roundtrip using @NixSerializer@ roundtripSReader @@ -139,17 +137,17 @@ spec = parallel $ do prop "StoreRequest" $ \testStoreConfig -> - forAll (arbitrary `suchThat` (hacks (hasProtoVersion testStoreConfig))) + forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig))) $ roundtripSReader @TestStoreConfig storeRequest testStoreConfig -hacks :: ProtoVersion -> Some StoreRequest -> Bool -hacks v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False -hacks _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty -hacks v (Some (QueryMissing _)) | v < ProtoVersion 1 30 = False -hacks _ _ = True +restrictProtoVersion :: ProtoVersion -> Some StoreRequest -> Bool +restrictProtoVersion v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False +restrictProtoVersion _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty +restrictProtoVersion v (Some (QueryMissing _)) | v < ProtoVersion 1 30 = False +restrictProtoVersion _ _ = True errorInfoIf :: Bool -> Logger -> Bool -errorInfoIf True (Logger_Error (Right _)) = True -errorInfoIf False (Logger_Error (Left _)) = True -errorInfoIf _ (Logger_Error _) = False -errorInfoIf _ _ = True +errorInfoIf True (Logger_Error (Right _)) = True +errorInfoIf False (Logger_Error (Left _)) = True +errorInfoIf _ (Logger_Error _) = False +errorInfoIf _ _ = True From 4adf509a7ed54c73f29f85413ba81ec457b11ef9 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 13:37:25 +0100 Subject: [PATCH 029/104] temp: add source-repository-package override for dependent-sum-template until https://github.com/obsidiansystems/dependent-sum-template/pull/7 and its next release. --- cabal.project | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/cabal.project b/cabal.project index bc00a4e..fb9fabe 100644 --- a/cabal.project +++ b/cabal.project @@ -21,3 +21,9 @@ package hnix-store-nar package hnix-store-remote flags: +build-derivation +build-readme +io-testsuite + +-- until https://github.com/obsidiansystems/dependent-sum-template/pull/7 +source-repository-package + type: git + location: https://github.com/ncfavier/dependent-sum-template/ + tag: 6614029b47ec3957c871b2bbec91fe79f230cf9e From 14f93bf30bc81a0eab5776d5c3040a3430f053f5 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 13:50:21 +0100 Subject: [PATCH 030/104] remote: add Types.TrusteFlag, serializer, use in client, more props for handshake Co-Authored-By: John Ericson --- hnix-store-remote/hnix-store-remote.cabal | 1 + .../src/System/Nix/Store/Remote/Arbitrary.hs | 13 +++++++++++++ .../src/System/Nix/Store/Remote/Client.hs | 9 ++++++++- .../src/System/Nix/Store/Remote/Serializer.hs | 17 +++++++++++++++++ .../src/System/Nix/Store/Remote/Types.hs | 2 ++ .../Nix/Store/Remote/Types/TrustedFlag.hs | 11 +++++++++++ .../System/Nix/Store/Remote/Types/WorkerOp.hs | 4 +++- hnix-store-remote/tests/NixSerializerSpec.hs | 6 ++++++ 8 files changed, 61 insertions(+), 2 deletions(-) create mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Types/TrustedFlag.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 2a85021..9420cca 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -92,6 +92,7 @@ library , System.Nix.Store.Remote.Types.StoreRequest , System.Nix.Store.Remote.Types.StoreText , System.Nix.Store.Remote.Types.SubstituteMode + , System.Nix.Store.Remote.Types.TrustedFlag , System.Nix.Store.Remote.Types.Verbosity , System.Nix.Store.Remote.Types.WorkerMagic , System.Nix.Store.Remote.Types.WorkerOp diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index 50ee94d..16db642 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -69,6 +69,19 @@ deriving via GenericArbitrary Logger deriving via GenericArbitrary Verbosity instance Arbitrary Verbosity +-- * Handshake + +deriving via GenericArbitrary WorkerMagic + instance Arbitrary WorkerMagic + +deriving via GenericArbitrary TrustedFlag + instance Arbitrary TrustedFlag + +-- * Worker protocol + +deriving via GenericArbitrary WorkerOp + instance Arbitrary WorkerOp + instance Arbitrary (Some StoreRequest) where arbitrary = oneof [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 152307c..9a62551 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -23,7 +23,7 @@ import qualified Network.Socket.ByteString import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) -import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, text, workerMagic) +import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, text, trustedFlag, workerMagic) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig(..), StoreConfig(..)) @@ -133,6 +133,13 @@ runStoreSocket preStoreConfig code = text return () + _remoteTrustsUs <- if ourProtoVersion >= ProtoVersion 1 35 + then do + sockGetS + $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag + else do + return Nothing + -- TODO do something with it -- TODO patter match better _ <- mapStoreConfig diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 79354ce..1c88de9 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -66,6 +66,7 @@ module System.Nix.Store.Remote.Serializer -- * Handshake , HandshakeSError(..) , workerMagic + , trustedFlag -- * Worker protocol , storeText , workerOp @@ -914,6 +915,7 @@ verbosity = Serializer data HandshakeSError = HandshakeSError_InvalidWorkerMagic Word64 + | HandshakeSError_InvalidTrustedFlag Word8 deriving (Eq, Ord, Generic, Show) workerMagic :: NixSerializer r HandshakeSError WorkerMagic @@ -927,6 +929,21 @@ workerMagic = Serializer , putS = putS int . workerMagicToWord64 } +trustedFlag :: NixSerializer r HandshakeSError (Maybe TrustedFlag) +trustedFlag = Serializer + { getS = do + n :: Word8 <- getS int + case n of + 0 -> return $ Nothing + 1 -> return $ Just TrustedFlag_Trusted + 2 -> return $ Just TrustedFlag_NotTrusted + _ -> throwError (HandshakeSError_InvalidTrustedFlag n) + , putS = \n -> putS int $ case n of + Nothing -> 0 :: Word8 + Just TrustedFlag_Trusted -> 1 + Just TrustedFlag_NotTrusted -> 2 + } + -- * Worker protocol storeText :: NixSerializer r SError StoreText diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs index d804263..ff22ae7 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs @@ -8,6 +8,7 @@ module System.Nix.Store.Remote.Types , module System.Nix.Store.Remote.Types.StoreRequest , module System.Nix.Store.Remote.Types.StoreText , module System.Nix.Store.Remote.Types.SubstituteMode + , module System.Nix.Store.Remote.Types.TrustedFlag , module System.Nix.Store.Remote.Types.Verbosity , module System.Nix.Store.Remote.Types.WorkerMagic , module System.Nix.Store.Remote.Types.WorkerOp @@ -22,6 +23,7 @@ import System.Nix.Store.Remote.Types.StoreConfig import System.Nix.Store.Remote.Types.StoreRequest import System.Nix.Store.Remote.Types.StoreText import System.Nix.Store.Remote.Types.SubstituteMode +import System.Nix.Store.Remote.Types.TrustedFlag import System.Nix.Store.Remote.Types.Verbosity import System.Nix.Store.Remote.Types.WorkerMagic import System.Nix.Store.Remote.Types.WorkerOp diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/TrustedFlag.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/TrustedFlag.hs new file mode 100644 index 0000000..9e51b57 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/TrustedFlag.hs @@ -0,0 +1,11 @@ +module System.Nix.Store.Remote.Types.TrustedFlag + ( TrustedFlag(..) + ) where + +import GHC.Generics (Generic) + +-- | Whether remote side trust us +data TrustedFlag + = TrustedFlag_Trusted + | TrustedFlag_NotTrusted + deriving (Bounded, Eq, Generic, Enum, Ord, Show) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs index c250db2..1839fad 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs @@ -2,6 +2,8 @@ module System.Nix.Store.Remote.Types.WorkerOp ( WorkerOp(..) ) where +import GHC.Generics (Generic) + -- | Worker opcode -- -- This type has gaps filled in so that the GHC builtin @@ -54,4 +56,4 @@ data WorkerOp | WorkerOp_AddMultipleToStore -- 44 0x2c | WorkerOp_AddBuildLog -- 45 0x2d | WorkerOp_BuildPathsWithResults -- 46 0x2e - deriving (Bounded, Eq, Enum, Ord, Show, Read) + deriving (Bounded, Eq, Enum, Generic, Ord, Show, Read) diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 0021b7c..09f3c4f 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -132,7 +132,13 @@ spec = parallel $ do it' "IsValidPath" WorkerOp_IsValidPath 1 it' "BuildPathsWithResults" WorkerOp_BuildPathsWithResults 46 + + describe "Handshake" $ do + prop "WorkerMagic" $ roundtripS workerMagic + prop "TrustedFlag" $ roundtripS trustedFlag + describe "Worker protocol" $ do + prop "WorkerOp" $ roundtripS workerOp prop "StoreText" $ roundtripS storeText prop "StoreRequest" From d5557680de2486450dae0d7a9285767639b9aa9b Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 13:58:33 +0100 Subject: [PATCH 031/104] remote: handshake - use minimumCommonVersion of our vs daemon protoVersion --- .../src/System/Nix/Store/Remote/Client.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 9a62551..abf1303 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -114,17 +114,17 @@ runStoreSocket preStoreConfig code = sockPutS protoVersion ourProtoVersion - when (daemonVersion >= ProtoVersion 1 14) + let minimumCommonVersion = min daemonVersion ourProtoVersion + + when (minimumCommonVersion >= ProtoVersion 1 14) $ sockPutS int (0 :: Int) -- affinity, obsolete - when (daemonVersion >= ProtoVersion 1 11) $ do + when (minimumCommonVersion >= ProtoVersion 1 11) $ do sockPutS (mapErrorS RemoteStoreError_SerializerPut bool) False -- reserveSpace, obsolete - -- not quite right, should be min of the two - -- as well as two ^ above - when (ourProtoVersion >= ProtoVersion 1 33) $ do + when (minimumCommonVersion >= ProtoVersion 1 33) $ do -- If we were buffering I/O, we would flush the output here. _daemonNixVersion <- sockGetS @@ -133,7 +133,7 @@ runStoreSocket preStoreConfig code = text return () - _remoteTrustsUs <- if ourProtoVersion >= ProtoVersion 1 35 + _remoteTrustsUs <- if minimumCommonVersion >= ProtoVersion 1 35 then do sockGetS $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag @@ -146,6 +146,4 @@ runStoreSocket preStoreConfig code = (\(PreStoreConfig a b) -> StoreConfig a ourProtoVersion b) processOutput - -- TODO should be minimum of - -- ourProtoVersion vs daemonVersion - pure ourProtoVersion + pure minimumCommonVersion From a8a4d66f6e1fe85dc0d8d2ee8087a6f6b9019da8 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 13:58:50 +0100 Subject: [PATCH 032/104] remote: protoVersion_minor 21 -> 24 --- .../src/System/Nix/Store/Remote/Types/ProtoVersion.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs index 159915b..766a83f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs @@ -23,5 +23,5 @@ instance HasProtoVersion ProtoVersion where ourProtoVersion :: ProtoVersion ourProtoVersion = ProtoVersion { protoVersion_major = 1 - , protoVersion_minor = 21 + , protoVersion_minor = 24 } From ea49946a198eec3f23285e31e61dc9b73f03ba86 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 14:04:22 +0100 Subject: [PATCH 033/104] remote: add preStoreConfigToStoreConfig, use in handshake --- .../src/System/Nix/Store/Remote/Client.hs | 7 +++---- .../System/Nix/Store/Remote/Types/StoreConfig.hs | 14 ++++++++++++++ 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index abf1303..3b87f70 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -26,7 +26,7 @@ import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, text, trustedFlag, workerMagic) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) -import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig(..), StoreConfig(..)) +import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, preStoreConfigToStoreConfig) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) @@ -83,7 +83,7 @@ runStoreSocket preStoreConfig code = runRemoteStoreT preStoreConfig $ do pv <- greet mapStoreConfig - (\(PreStoreConfig a b) -> StoreConfig a pv b) + (preStoreConfigToStoreConfig pv) code where @@ -141,9 +141,8 @@ runStoreSocket preStoreConfig code = return Nothing -- TODO do something with it - -- TODO patter match better _ <- mapStoreConfig - (\(PreStoreConfig a b) -> StoreConfig a ourProtoVersion b) + (preStoreConfigToStoreConfig minimumCommonVersion) processOutput pure minimumCommonVersion diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs index db30b74..4735fa8 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs @@ -4,6 +4,7 @@ module System.Nix.Store.Remote.Types.StoreConfig , StoreConfig(..) , TestStoreConfig(..) , HasStoreSocket(..) + , preStoreConfigToStoreConfig ) where import GHC.Generics (Generic) @@ -56,3 +57,16 @@ instance HasProtoVersion TestStoreConfig where instance HasStoreDir TestStoreConfig where hasStoreDir = testStoreConfig_dir + +-- | Convert @PreStoreConfig@ to @StoreConfig@ +-- adding @ProtoVersion@ to latter +preStoreConfigToStoreConfig + :: ProtoVersion + -> PreStoreConfig + -> StoreConfig +preStoreConfigToStoreConfig pv PreStoreConfig{..} = + StoreConfig + { storeConfig_dir = preStoreConfig_dir + , storeConfig_protoVersion = pv + , storeConfig_socket = preStoreConfig_socket + } From a05377a98333b5372d7d030e2159a007603c2d28 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 14:19:22 +0100 Subject: [PATCH 034/104] remote: add Types.Handshake, use as a greeting result --- hnix-store-remote/hnix-store-remote.cabal | 1 + .../src/System/Nix/Store/Remote/Client.hs | 46 +++++++++++-------- .../Nix/Store/Remote/Types/Handshake.hs | 19 ++++++++ 3 files changed, 47 insertions(+), 19 deletions(-) create mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 9420cca..b38bd32 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -86,6 +86,7 @@ library , System.Nix.Store.Remote.Types.Activity , System.Nix.Store.Remote.Types.CheckMode , System.Nix.Store.Remote.Types.GC + , System.Nix.Store.Remote.Types.Handshake , System.Nix.Store.Remote.Types.Logger , System.Nix.Store.Remote.Types.ProtoVersion , System.Nix.Store.Remote.Types.StoreConfig diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 3b87f70..b26b17a 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -24,6 +24,7 @@ import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, text, trustedFlag, workerMagic) +import System.Nix.Store.Remote.Types.Handshake (Handshake(..)) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, preStoreConfigToStoreConfig) @@ -81,13 +82,13 @@ runStoreSocket -> Run a runStoreSocket preStoreConfig code = runRemoteStoreT preStoreConfig $ do - pv <- greet + Handshake{..} <- greet mapStoreConfig - (preStoreConfigToStoreConfig pv) + (preStoreConfigToStoreConfig handshakeProtoVersion) code where - greet :: MonadRemoteStoreHandshake ProtoVersion + greet :: MonadRemoteStoreHandshake Handshake greet = do sockPutS @@ -124,25 +125,32 @@ runStoreSocket preStoreConfig code = (mapErrorS RemoteStoreError_SerializerPut bool) False -- reserveSpace, obsolete - when (minimumCommonVersion >= ProtoVersion 1 33) $ do - -- If we were buffering I/O, we would flush the output here. - _daemonNixVersion <- - sockGetS - $ mapErrorS - RemoteStoreError_SerializerGet - text - return () + daemonNixVersion <- if minimumCommonVersion >= 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 minimumCommonVersion >= ProtoVersion 1 35 + remoteTrustsUs <- if minimumCommonVersion >= ProtoVersion 1 35 then do sockGetS $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag - else do - return Nothing + else pure Nothing - -- TODO do something with it - _ <- mapStoreConfig - (preStoreConfigToStoreConfig minimumCommonVersion) - processOutput + logs <- + mapStoreConfig + (preStoreConfigToStoreConfig minimumCommonVersion) + processOutput - pure minimumCommonVersion + pure Handshake + { handshakeNixVersion = daemonNixVersion + , handshakeTrust = remoteTrustsUs + , handshakeProtoVersion = minimumCommonVersion + , handshakeRemoteProtoVersion = daemonVersion + , handshakeLogs = logs + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs new file mode 100644 index 0000000..644394c --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs @@ -0,0 +1,19 @@ +module System.Nix.Store.Remote.Types.Handshake + ( Handshake(..) + ) where + +import Data.Text (Text) +import GHC.Generics (Generic) +import System.Nix.Store.Remote.Types.Logger (Logger) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) +import System.Nix.Store.Remote.Types.TrustedFlag (TrustedFlag) + +-- | Data for initial protocol handshake +data Handshake = Handshake + { handshakeNixVersion :: Maybe Text -- ^ Textual version, since 1.33 + , handshakeTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us + , handshakeProtoVersion :: ProtoVersion -- ^ Minimum protocol supported by both sides + , handshakeRemoteProtoVersion :: ProtoVersion -- ^ Protocol supported by remote side + , handshakeLogs :: [Logger] -- ^ Logs produced right after greeting exchange + } + deriving (Eq, Generic, Ord, Show) From 8b1db174bc93eb46b8fee2e0fa0fe940b66c86ac Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 14:45:05 +0100 Subject: [PATCH 035/104] remote: add Types.Query.Missing for QueryMissing result --- hnix-store-remote/hnix-store-remote.cabal | 2 ++ .../src/System/Nix/Store/Remote.hs | 21 +++++++------------ .../src/System/Nix/Store/Remote/Types.hs | 2 ++ .../System/Nix/Store/Remote/Types/Query.hs | 5 +++++ .../Nix/Store/Remote/Types/Query/Missing.hs | 18 ++++++++++++++++ .../Nix/Store/Remote/Types/StoreRequest.hs | 9 ++------ hnix-store-remote/tests-io/NixDaemon.hs | 10 ++++++++- 7 files changed, 46 insertions(+), 21 deletions(-) create mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Types/Query.hs create mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Types/Query/Missing.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index b38bd32..7d327f3 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -89,6 +89,8 @@ library , System.Nix.Store.Remote.Types.Handshake , System.Nix.Store.Remote.Types.Logger , System.Nix.Store.Remote.Types.ProtoVersion + , System.Nix.Store.Remote.Types.Query + , System.Nix.Store.Remote.Types.Query.Missing , System.Nix.Store.Remote.Types.StoreConfig , System.Nix.Store.Remote.Types.StoreRequest , System.Nix.Store.Remote.Types.StoreText diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index aa582ed..a30836f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -401,23 +401,18 @@ queryPathFromHashPart storePathHash = do queryMissing :: (HashSet StorePath) - -> MonadStore - ( HashSet StorePath -- Paths that will be built - , HashSet StorePath -- Paths that have substitutes - , HashSet StorePath -- Unknown paths - , Integer -- Download size - , Integer -- Nar size? - ) + -> MonadStore Missing queryMissing ps = do storeDir <- getStoreDir runOpArgs WorkerOp_QueryMissing $ putPaths storeDir ps - willBuild <- sockGetPaths - willSubstitute <- sockGetPaths - unknown <- sockGetPaths - downloadSize' <- sockGetInt - narSize' <- sockGetInt - pure (willBuild, willSubstitute, unknown, downloadSize', narSize') + missingWillBuild <- sockGetPaths + missingWillSubstitute <- sockGetPaths + missingUnknownPaths <- sockGetPaths + missingDownloadSize <- sockGetInt + missingNarSize <- sockGetInt + + pure Missing{..} optimiseStore :: MonadStore () optimiseStore = Control.Monad.void $ simpleOp WorkerOp_OptimiseStore diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs index ff22ae7..8c23f96 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs @@ -4,6 +4,7 @@ module System.Nix.Store.Remote.Types , module System.Nix.Store.Remote.Types.CheckMode , module System.Nix.Store.Remote.Types.Logger , module System.Nix.Store.Remote.Types.ProtoVersion + , module System.Nix.Store.Remote.Types.Query , module System.Nix.Store.Remote.Types.StoreConfig , module System.Nix.Store.Remote.Types.StoreRequest , module System.Nix.Store.Remote.Types.StoreText @@ -19,6 +20,7 @@ import System.Nix.Store.Remote.Types.GC import System.Nix.Store.Remote.Types.CheckMode import System.Nix.Store.Remote.Types.Logger import System.Nix.Store.Remote.Types.ProtoVersion +import System.Nix.Store.Remote.Types.Query import System.Nix.Store.Remote.Types.StoreConfig import System.Nix.Store.Remote.Types.StoreRequest import System.Nix.Store.Remote.Types.StoreText diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query.hs new file mode 100644 index 0000000..82ef238 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query.hs @@ -0,0 +1,5 @@ +module System.Nix.Store.Remote.Types.Query + ( module System.Nix.Store.Remote.Types.Query.Missing + ) where + +import System.Nix.Store.Remote.Types.Query.Missing diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query/Missing.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query/Missing.hs new file mode 100644 index 0000000..534bd0f --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query/Missing.hs @@ -0,0 +1,18 @@ +module System.Nix.Store.Remote.Types.Query.Missing + ( Missing(..) + ) where + +import Data.HashSet (HashSet) +import Data.Word (Word64) +import GHC.Generics (Generic) +import System.Nix.StorePath (StorePath) + +-- | Result of @QueryMissing@ @StoreRequest@ +data Missing = Missing + { missingWillBuild :: HashSet StorePath -- ^ Paths that will be built + , missingWillSubstitute :: HashSet StorePath -- ^ Paths that can be substituted from cache + , missingUnknownPaths :: HashSet StorePath -- ^ Path w/o any information + , missingDownloadSize :: Word64 -- ^ Total size of packed NARs to download + , missingNarSize :: Word64 -- ^ Total size of NARs after unpacking + } + deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs index fb409be..2ea9a4b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -24,6 +24,7 @@ import System.Nix.Store.Types (FileIngestionMethod, RepairMode) import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.Types.CheckMode (CheckMode) +import System.Nix.Store.Remote.Types.Query.Missing (Missing) import System.Nix.Store.Remote.Types.StoreText (StoreText) import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode) @@ -138,13 +139,7 @@ data StoreRequest :: Type -> Type where QueryMissing :: Set DerivedPath - -> StoreRequest - ( HashSet StorePath -- Paths that will be built - , HashSet StorePath -- Paths that have substitutes - , HashSet StorePath -- Unknown paths - , Integer -- Download size - , Integer -- Nar size? - ) + -> StoreRequest Missing OptimiseStore :: StoreRequest () diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index f55b881..a0dc825 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemon.hs @@ -262,7 +262,15 @@ spec_protocol = Hspec.around withNixDaemon $ context "queryMissing" $ itRights "queries" $ withPath $ \path -> do let pathSet = HS.fromList [path] - queryMissing pathSet `shouldReturn` (HS.empty, HS.empty, HS.empty, 0, 0) + queryMissing pathSet + `shouldReturn` + Missing + { missingWillBuild = mempty + , missingWillSubstitute = mempty + , missingUnknownPaths = mempty + , missingDownloadSize = 0 + , missingNarSize = 0 + } context "addToStore" $ itRights "adds file to store" $ do From 265d25256ddd45667bb2068dde76691f016ef22d Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 15:12:54 +0100 Subject: [PATCH 036/104] core: split signature/narSignature parser/builder --- hnix-store-core/src/System/Nix/Signature.hs | 53 ++++++++++++++------- hnix-store-core/tests/Fingerprint.hs | 8 ++-- hnix-store-core/tests/Signature.hs | 8 ++-- hnix-store-tests/tests/SignatureSpec.hs | 4 +- 4 files changed, 46 insertions(+), 27 deletions(-) diff --git a/hnix-store-core/src/System/Nix/Signature.hs b/hnix-store-core/src/System/Nix/Signature.hs index 3a16c52..c8e55b7 100644 --- a/hnix-store-core/src/System/Nix/Signature.hs +++ b/hnix-store-core/src/System/Nix/Signature.hs @@ -6,13 +6,17 @@ Description : Nix-relevant interfaces to NaCl signatures. module System.Nix.Signature ( Signature(..) - , NarSignature(..) , signatureParser , parseSignature , signatureToText + , NarSignature(..) + , narSignatureParser + , parseNarSignature + , narSignatureToText ) where import Crypto.Error (CryptoFailable(..)) +import Data.Attoparsec.Text (Parser) import Data.ByteString (ByteString) import Data.Text (Text) import GHC.Generics (Generic) @@ -28,6 +32,26 @@ import qualified Data.Text newtype Signature = Signature Ed25519.Signature deriving (Eq, Generic, Show) +signatureParser :: Parser Signature +signatureParser = do + encodedSig <- + Data.Attoparsec.Text.takeWhile1 + (\c -> Data.Char.isAlphaNum c || c == '+' || c == '/' || c == '=') + decodedSig <- case decodeWith Base64 encodedSig of + Left e -> fail e + Right decodedSig -> pure decodedSig + sig <- case Ed25519.signature decodedSig of + CryptoFailed e -> (fail . show) e + CryptoPassed sig -> pure sig + pure $ Signature sig + +parseSignature :: Text -> Either String Signature +parseSignature = Data.Attoparsec.Text.parseOnly signatureParser + +signatureToText :: Signature -> Text +signatureToText (Signature sig) = + encodeWith Base64 (Data.ByteArray.convert sig :: ByteString) + -- | A detached signature attesting to a nix archive's validity. data NarSignature = NarSignature { -- | The name of the public key used to sign the archive. @@ -43,26 +67,19 @@ instance Ord Signature where yBS = Data.ByteArray.convert y :: ByteString in compare xBS yBS -signatureParser :: Data.Attoparsec.Text.Parser NarSignature -signatureParser = do +narSignatureParser :: Parser NarSignature +narSignatureParser = do publicKey <- Data.Attoparsec.Text.takeWhile1 (/= ':') _ <- Data.Attoparsec.Text.string ":" - encodedSig <- Data.Attoparsec.Text.takeWhile1 (\c -> Data.Char.isAlphaNum c || c == '+' || c == '/' || c == '=') - decodedSig <- case decodeWith Base64 encodedSig of - Left e -> fail e - Right decodedSig -> pure decodedSig - sig <- case Ed25519.signature decodedSig of - CryptoFailed e -> (fail . show) e - CryptoPassed sig -> pure sig - pure $ NarSignature publicKey (Signature sig) + sig <- signatureParser + pure $ NarSignature {..} -parseSignature :: Text -> Either String NarSignature -parseSignature = Data.Attoparsec.Text.parseOnly signatureParser +parseNarSignature :: Text -> Either String NarSignature +parseNarSignature = Data.Attoparsec.Text.parseOnly narSignatureParser -signatureToText :: NarSignature -> Text -signatureToText NarSignature {publicKey, sig=Signature sig'} = let - b64Encoded = encodeWith Base64 (Data.ByteArray.convert sig' :: ByteString) - in mconcat [ publicKey, ":", b64Encoded ] +narSignatureToText :: NarSignature -> Text +narSignatureToText NarSignature {..} = + mconcat [ publicKey, ":", signatureToText sig ] instance Show NarSignature where - show narSig = Data.Text.unpack (signatureToText narSig) + show narSig = Data.Text.unpack (narSignatureToText narSig) diff --git a/hnix-store-core/tests/Fingerprint.hs b/hnix-store-core/tests/Fingerprint.hs index ad949b4..68e4926 100644 --- a/hnix-store-core/tests/Fingerprint.hs +++ b/hnix-store-core/tests/Fingerprint.hs @@ -48,19 +48,19 @@ exampleMetadata = Metadata , registrationTime = UTCTime (fromOrdinalDate 0 0) 0 , narBytes = Just 196040 , trust = BuiltElsewhere - , sigs = Set.fromList $ forceRight . parseSignature <$> ["cache.nixos.org-1:TsTTb3WGTZKphvYdBHXwo6weVILmTytUjLB+vcX89fOjjRicCHmKA4RCPMVLkj6TMJ4GMX3HPVWRdD1hkeKZBQ==", "test1:519iiVLx/c4Rdt5DNt6Y2Jm6hcWE9+XY69ygiWSZCNGVcmOcyL64uVAJ3cV8vaTusIZdbTnYo9Y7vDNeTmmMBQ=="] + , sigs = Set.fromList $ forceRight . parseNarSignature <$> ["cache.nixos.org-1:TsTTb3WGTZKphvYdBHXwo6weVILmTytUjLB+vcX89fOjjRicCHmKA4RCPMVLkj6TMJ4GMX3HPVWRdD1hkeKZBQ==", "test1:519iiVLx/c4Rdt5DNt6Y2Jm6hcWE9+XY69ygiWSZCNGVcmOcyL64uVAJ3cV8vaTusIZdbTnYo9Y7vDNeTmmMBQ=="] , contentAddress = Nothing } pubkey :: Ed25519.PublicKey pubkey = forceDecodeB64Pubkey "6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" - + forceDecodeB64Pubkey :: Text -> Ed25519.PublicKey forceDecodeB64Pubkey b64EncodedPubkey = let decoded = forceRight $ decodeWith Base64 b64EncodedPubkey - in case Ed25519.publicKey decoded of + in case Ed25519.publicKey decoded of CryptoFailed err -> (error . show) err - CryptoPassed x -> x + CryptoPassed x -> x forceRight :: Either a b -> b forceRight = \case diff --git a/hnix-store-core/tests/Signature.hs b/hnix-store-core/tests/Signature.hs index fa88717..5841a2b 100644 --- a/hnix-store-core/tests/Signature.hs +++ b/hnix-store-core/tests/Signature.hs @@ -54,24 +54,24 @@ pubkeyNixosOrg :: Crypto.PubKey.Ed25519.PublicKey pubkeyNixosOrg = forceDecodeB64Pubkey "6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" shouldNotParse :: Text -> Expectation -shouldNotParse encoded = case parseSignature encoded of +shouldNotParse encoded = case parseNarSignature encoded of Left _ -> pure () Right _ -> expectationFailure "should not have parsed" shouldParseName :: Text -> Text -> Expectation -shouldParseName encoded name = case parseSignature encoded of +shouldParseName encoded name = case parseNarSignature encoded of Left err -> expectationFailure err Right narSig -> shouldBe name (publicKey narSig) shouldVerify :: Text -> Crypto.PubKey.Ed25519.PublicKey -> BS.ByteString -> Expectation -shouldVerify encoded pubkey msg = case parseSignature encoded of +shouldVerify encoded pubkey msg = case parseNarSignature encoded of Left err -> expectationFailure err Right narSig -> let (Signature sig') = sig narSig in sig' `shouldSatisfy` Crypto.PubKey.Ed25519.verify pubkey msg shouldNotVerify :: Text -> Crypto.PubKey.Ed25519.PublicKey -> BS.ByteString -> Expectation -shouldNotVerify encoded pubkey msg = case parseSignature encoded of +shouldNotVerify encoded pubkey msg = case parseNarSignature encoded of Left err -> expectationFailure err Right narSig -> let (Signature sig') = sig narSig diff --git a/hnix-store-tests/tests/SignatureSpec.hs b/hnix-store-tests/tests/SignatureSpec.hs index 3814e5b..e7f6dd6 100644 --- a/hnix-store-tests/tests/SignatureSpec.hs +++ b/hnix-store-tests/tests/SignatureSpec.hs @@ -4,10 +4,12 @@ import Test.Hspec (Spec, describe) import Test.Hspec.Nix (roundtrips) import Test.Hspec.QuickCheck (prop) -import System.Nix.Signature (signatureToText, parseSignature) +import System.Nix.Signature (signatureToText, parseSignature, narSignatureToText, parseNarSignature) import System.Nix.Arbitrary () spec :: Spec spec = do describe "Signature" $ do prop "roundtrips" $ roundtrips signatureToText parseSignature + describe "NarSignature" $ do + prop "roundtrips" $ roundtrips narSignatureToText parseNarSignature From 6074504bcc944c9c12fc76cceb0ad4e7c7e38ae2 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 15:13:34 +0100 Subject: [PATCH 037/104] remote: change AddSignatures from [ByteString] to Set Signature --- .../src/System/Nix/Store/Remote.hs | 3 +- .../src/System/Nix/Store/Remote/Serializer.hs | 43 +++++++++++++------ .../Nix/Store/Remote/Types/StoreRequest.hs | 3 +- 3 files changed, 33 insertions(+), 16 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index a30836f..822f6fb 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -349,7 +349,8 @@ queryPathInfoUncached path = do let sigs = case - Data.Set.fromList <$> mapM (Data.Attoparsec.Text.parseOnly System.Nix.Signature.signatureParser) sigStrings + Data.Set.fromList + <$> mapM System.Nix.Signature.parseNarSignature sigStrings of Left e -> error e Right x -> x diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 1c88de9..f6801ca 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -40,6 +40,9 @@ module System.Nix.Store.Remote.Serializer , storePathName -- * Metadata , pathMetadata + -- * Signatures + , signature + , narSignature -- * Some HashAlgo , someHashAlgo -- * Digest @@ -115,7 +118,7 @@ import System.Nix.ContentAddress (ContentAddress) import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) import System.Nix.DerivedPath (DerivedPath, ParseOutputsError) import System.Nix.Hash (HashAlgo) -import System.Nix.Signature (NarSignature) +import System.Nix.Signature (Signature, NarSignature) import System.Nix.StorePath (HasStoreDir(..), InvalidPathError, StorePath, StorePathHashPart, StorePathName) import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) import System.Nix.Store.Remote.Types @@ -505,7 +508,7 @@ pathMetadata = Serializer size -> Just size) <$> getS int trust <- getS storePathTrust - sigs <- getS $ set signature + sigs <- getS $ set narSignature contentAddress <- getS maybeContentAddress pure $ Metadata{..} @@ -527,7 +530,7 @@ pathMetadata = Serializer putS time registrationTime putS int $ Prelude.maybe 0 id $ narBytes putS storePathTrust trust - putS (set signature) sigs + putS (set narSignature) sigs putS maybeContentAddress contentAddress } where @@ -553,15 +556,27 @@ pathMetadata = Serializer (\case BuiltElsewhere -> False; BuiltLocally -> True) bool - signature - :: NixSerializer r SError NarSignature - signature = - mapPrismSerializer - (Data.Bifunctor.first SError_Signature - . Data.Attoparsec.Text.parseOnly - System.Nix.Signature.signatureParser) - (System.Nix.Signature.signatureToText) - text +-- * Signatures + +signature + :: NixSerializer r SError Signature +signature = + mapPrismSerializer + (Data.Bifunctor.first SError_Signature + . Data.Attoparsec.Text.parseOnly + System.Nix.Signature.signatureParser) + (System.Nix.Signature.signatureToText) + text + +narSignature + :: NixSerializer r SError NarSignature +narSignature = + mapPrismSerializer + (Data.Bifunctor.first SError_Signature + . Data.Attoparsec.Text.parseOnly + System.Nix.Signature.narSignatureParser) + (System.Nix.Signature.narSignatureToText) + text -- * Some HashAlgo @@ -982,7 +997,7 @@ storeRequest = Serializer WorkerOp_AddSignatures -> do path <- getS storePath - signatures <- getS (list byteString) + signatures <- getS (set signature) pure $ Some (AddSignatures path signatures) WorkerOp_AddIndirectRoot -> @@ -1101,7 +1116,7 @@ storeRequest = Serializer putS workerOp WorkerOp_AddSignatures putS storePath path - putS (list byteString) signatures + putS (set signature) signatures Some (AddIndirectRoot path) -> do putS workerOp WorkerOp_AddIndirectRoot diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs index 2ea9a4b..afa206c 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -20,6 +20,7 @@ import System.Nix.Build (BuildMode, BuildResult) import System.Nix.Derivation (Derivation) import System.Nix.DerivedPath (DerivedPath) import System.Nix.Hash (HashAlgo) +import System.Nix.Signature (Signature) import System.Nix.Store.Types (FileIngestionMethod, RepairMode) import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) import System.Nix.StorePath.Metadata (Metadata) @@ -58,7 +59,7 @@ data StoreRequest :: Type -> Type where AddSignatures :: StorePath - -> [ByteString] + -> Set Signature -> StoreRequest () -- | Add temporary garbage collector root. From 217ea1b8ad734e6034eb259bd058eb74830ee9c4 Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 15:26:21 +0100 Subject: [PATCH 038/104] remote: add CollectGarbage StoreRequest --- .../src/System/Nix/Store/Remote/Arbitrary.hs | 12 ++++++++++ .../src/System/Nix/Store/Remote/Serializer.hs | 22 ++++++++++++++++++- .../src/System/Nix/Store/Remote/Types/GC.hs | 2 +- .../Nix/Store/Remote/Types/StoreRequest.hs | 6 +++++ 4 files changed, 40 insertions(+), 2 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index 16db642..e5869b5 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -69,6 +69,17 @@ deriving via GenericArbitrary Logger deriving via GenericArbitrary Verbosity instance Arbitrary Verbosity +-- * GC + +deriving via GenericArbitrary GCAction + instance Arbitrary GCAction + +deriving via GenericArbitrary GCOptions + instance Arbitrary GCOptions + +deriving via GenericArbitrary GCResult + instance Arbitrary GCResult + -- * Handshake deriving via GenericArbitrary WorkerMagic @@ -91,6 +102,7 @@ instance Arbitrary (Some StoreRequest) where , Some . AddTempRoot <$> arbitrary , Some <$> (BuildPaths <$> arbitrary <*> arbitrary) , Some <$> (BuildDerivation <$> arbitrary <*> arbitrary <*> arbitrary) + , Some . CollectGarbage <$> arbitrary , Some . EnsurePath <$> arbitrary , pure $ Some FindRoots , Some . IsValidPath <$> arbitrary diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index f6801ca..63816c3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -1017,6 +1017,16 @@ storeRequest = Serializer buildMode' <- getS buildMode pure $ Some (BuildDerivation path drv buildMode') + WorkerOp_CollectGarbage -> do + gcOptions_operation <- getS enum + gcOptions_pathsToDelete <- getS (hashSet storePath) + gcOptions_ignoreLiveness <- getS bool + gcOptions_maxFreed <- getS int + -- obsolete fields + Control.Monad.forM_ [0..(2 :: Word8)] + $ pure $ getS (int @Word8) + pure $ Some (CollectGarbage GCOptions{..}) + WorkerOp_EnsurePath -> Some . EnsurePath <$> getS storePath @@ -1080,7 +1090,6 @@ storeRequest = Serializer WorkerOp_AddToStoreNar -> undefined WorkerOp_BuildPathsWithResults -> undefined WorkerOp_ClearFailedPaths -> undefined - WorkerOp_CollectGarbage -> undefined WorkerOp_ExportPath -> undefined WorkerOp_HasSubstitutes -> undefined WorkerOp_ImportPaths -> undefined @@ -1139,6 +1148,17 @@ storeRequest = Serializer putS derivation drv putS buildMode buildMode' + Some (CollectGarbage GCOptions{..}) -> do + putS workerOp WorkerOp_CollectGarbage + + putS enum gcOptions_operation + putS (hashSet storePath) gcOptions_pathsToDelete + putS bool gcOptions_ignoreLiveness + putS int gcOptions_maxFreed + -- obsolete fields + Control.Monad.forM_ [0..(2 :: Word8)] + $ pure $ putS int (0 :: Word8) + Some (EnsurePath path) -> do putS workerOp WorkerOp_EnsurePath putS storePath path diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs index 0eb5e9d..8fdda8b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs @@ -30,7 +30,7 @@ data GCOptions = GCOptions -- | Paths to delete for @GCAction_DeleteSpecific@ , gcOptions_pathsToDelete :: HashSet StorePath -- | Stop after `gcOptions_maxFreed` bytes have been freed - , gcOptions_maxFreed :: Integer + , gcOptions_maxFreed :: Word64 } deriving (Eq, Generic, Ord, Show) -- | Result of the garbage collection operation diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs index afa206c..1e74c2e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -24,6 +24,7 @@ import System.Nix.Signature (Signature) import System.Nix.Store.Types (FileIngestionMethod, RepairMode) import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) import System.Nix.StorePath.Metadata (Metadata) +import System.Nix.Store.Remote.Types.GC (GCOptions, GCResult) import System.Nix.Store.Remote.Types.CheckMode (CheckMode) import System.Nix.Store.Remote.Types.Query.Missing (Missing) import System.Nix.Store.Remote.Types.StoreText (StoreText) @@ -87,6 +88,10 @@ data StoreRequest :: Type -> Type where -> BuildMode -> StoreRequest BuildResult + CollectGarbage + :: GCOptions + -> StoreRequest GCResult + EnsurePath :: StorePath -> StoreRequest () @@ -169,6 +174,7 @@ instance {-# OVERLAPPING #-} Eq (Some StoreRequest) where Some (AddTempRoot a) == Some (AddTempRoot a') = a == a' Some (BuildPaths a b) == Some (BuildPaths a' b') = (a, b) == (a', b') Some (BuildDerivation a b c) == Some (BuildDerivation a' b' c') = (a, b, c) == (a', b', c') + Some (CollectGarbage a) == Some (CollectGarbage a') = a == a' Some (EnsurePath a) == Some (EnsurePath a') = a == a' Some (FindRoots) == Some (FindRoots) = True Some (IsValidPath a) == Some (IsValidPath a') = a == a' From bc98de1bf377d89c84b66555b88b1d00d23a18f8 Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 07:24:58 +0100 Subject: [PATCH 039/104] remote: drop MonadRemote* store aliases --- .../src/System/Nix/Store/Remote.hs | 12 +-- .../src/System/Nix/Store/Remote/Client.hs | 74 +++++++++++++----- .../src/System/Nix/Store/Remote/Logger.hs | 15 ++-- .../src/System/Nix/Store/Remote/MonadStore.hs | 47 ++++++------ .../src/System/Nix/Store/Remote/Socket.hs | 75 +++++++++++++------ 5 files changed, 150 insertions(+), 73 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 822f6fb..0cd57e3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -72,7 +72,7 @@ import qualified System.Nix.Hash import qualified System.Nix.Signature import qualified System.Nix.StorePath -import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed)) +import System.Nix.Store.Remote.MonadStore (RemoteStoreT, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed)) import System.Nix.Store.Remote.Client (Run, runStoreSocket, runOp, runOpArgs, runOpArgsIO, simpleOp, simpleOpArgs) import System.Nix.Store.Remote.Socket import System.Nix.Store.Remote.Types @@ -83,11 +83,11 @@ import System.Nix.Store.Remote.Serialize.Prim -- * Compat -type MonadStore = MonadRemoteStore +type MonadStore = RemoteStoreT StoreConfig IO -- * Runners -runStore :: MonadStore a -> Run a +runStore :: MonadStore a -> Run IO a runStore = runStoreOpts defaultSockPath def where defaultSockPath :: String @@ -97,7 +97,7 @@ runStoreOpts :: FilePath -> StoreDir -> MonadStore a - -> Run a + -> Run IO a runStoreOpts socketPath = runStoreOpts' Network.Socket.AF_UNIX @@ -108,7 +108,7 @@ runStoreOptsTCP -> Int -> StoreDir -> MonadStore a - -> Run a + -> Run IO a runStoreOptsTCP host port sd code = do Network.Socket.getAddrInfo (Just Network.Socket.defaultHints) @@ -128,7 +128,7 @@ runStoreOpts' -> SockAddr -> StoreDir -> MonadStore a - -> Run a + -> Run IO a runStoreOpts' sockFamily sockAddr storeRootDir code = Control.Exception.bracket open diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index b26b17a..857cd24 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -13,7 +13,7 @@ module System.Nix.Store.Remote.Client import Control.Monad (unless, when) import Control.Monad.Except (throwError) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Serialize.Put (Put, runPut) import qualified Data.Bool @@ -26,17 +26,30 @@ import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, text, trustedFlag, workerMagic) import System.Nix.Store.Remote.Types.Handshake (Handshake(..)) import System.Nix.Store.Remote.Types.Logger (Logger) -import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) -import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, preStoreConfigToStoreConfig) +import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion, ProtoVersion(..), ourProtoVersion) +import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket, PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) -type Run a = IO (Either RemoteStoreError a, [Logger]) - -simpleOp :: WorkerOp -> MonadRemoteStore Bool +simpleOp + :: ( Monad m + , MonadIO m + , HasProtoVersion r + , HasStoreSocket r + ) + => WorkerOp + -> RemoteStoreT r m Bool simpleOp op = simpleOpArgs op $ pure () -simpleOpArgs :: WorkerOp -> Put -> MonadRemoteStore Bool +simpleOpArgs + :: ( Monad m + , MonadIO m + , HasProtoVersion r + , HasStoreSocket r + ) + => WorkerOp + -> Put + -> RemoteStoreT r m Bool simpleOpArgs op args = do runOpArgs op args err <- gotError @@ -48,21 +61,41 @@ simpleOpArgs op args = do ) err -runOp :: WorkerOp -> MonadRemoteStore () +runOp + :: ( Monad m + , MonadIO m + , HasProtoVersion r + , HasStoreSocket r + ) + => WorkerOp + -> RemoteStoreT r m () runOp op = runOpArgs op $ pure () -runOpArgs :: WorkerOp -> Put -> MonadRemoteStore () +runOpArgs + :: ( Monad m + , MonadIO m + , HasProtoVersion r + , HasStoreSocket r + ) + => WorkerOp + -> Put + -> RemoteStoreT r m () runOpArgs op args = runOpArgsIO op (\encode -> encode $ runPut args) runOpArgsIO - :: WorkerOp - -> ((Data.ByteString.ByteString -> MonadRemoteStore ()) - -> MonadRemoteStore () + :: ( Monad m + , MonadIO m + , HasProtoVersion r + , HasStoreSocket r ) - -> MonadRemoteStore () + => WorkerOp + -> ((Data.ByteString.ByteString -> RemoteStoreT r m ()) + -> RemoteStoreT r m () + ) + -> RemoteStoreT r m () runOpArgsIO op encoder = do sockPutS (mapErrorS RemoteStoreError_SerializerPut enum) op @@ -76,10 +109,15 @@ runOpArgsIO op encoder = do -- TODO: don't use show getErrors >>= throwError . RemoteStoreError_Fixme . show +type Run m a = m (Either RemoteStoreError a, [Logger]) + runStoreSocket - :: PreStoreConfig - -> MonadRemoteStore a - -> Run a + :: ( Monad m + , MonadIO m + ) + => PreStoreConfig + -> RemoteStoreT StoreConfig m a + -> Run m a runStoreSocket preStoreConfig code = runRemoteStoreT preStoreConfig $ do Handshake{..} <- greet @@ -88,7 +126,9 @@ runStoreSocket preStoreConfig code = code where - greet :: MonadRemoteStoreHandshake Handshake + greet + :: MonadIO m + => RemoteStoreT PreStoreConfig m Handshake greet = do sockPutS 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 7daee30..6226f29 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -3,12 +3,13 @@ module System.Nix.Store.Remote.Logger ) where import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (MonadIO) import Data.ByteString (ByteString) 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 (MonadRemoteStore0, RemoteStoreError(..), clearData, getData, getProtoVersion) +import System.Nix.Store.Remote.MonadStore (RemoteStoreT, 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(..)) @@ -18,10 +19,12 @@ import qualified Data.Serialize.Get import qualified Data.Serializer processOutput - :: ( HasProtoVersion r + :: ( Monad m + , MonadIO m + , HasProtoVersion r , HasStoreSocket r ) - => MonadRemoteStore0 r [Logger] + => RemoteStoreT r m [Logger] processOutput = do protoVersion <- getProtoVersion sockGet8 >>= go . (decoder protoVersion) @@ -35,11 +38,13 @@ processOutput = do (runSerialT protoVersion $ Data.Serializer.getS logger) go - :: ( HasProtoVersion r + :: ( Monad m + , MonadIO m + , HasProtoVersion r , HasStoreSocket r ) => Result (Either LoggerSError Logger) - -> MonadRemoteStore0 r [Logger] + -> RemoteStoreT r m [Logger] go (Done ectrl leftover) = do Control.Monad.unless (leftover == mempty) $ 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 9781383..82db33a 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -7,9 +7,6 @@ module System.Nix.Store.Remote.MonadStore , RemoteStoreT , runRemoteStoreT , mapStoreConfig - , MonadRemoteStore0 - , MonadRemoteStore - , MonadRemoteStoreHandshake -- * Reader helpers , getStoreDir , getStoreSocket @@ -41,7 +38,7 @@ import System.Nix.StorePath (HasStoreDir(..), StoreDir) import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, SError) import System.Nix.Store.Remote.Types.Logger (Logger, isError) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) -import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), PreStoreConfig, StoreConfig) +import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..)) data RemoteStoreState = RemoteStoreState { remoteStoreState_logs :: [Logger] @@ -111,15 +108,9 @@ runRemoteStoreT r = , 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) + -> (RemoteStoreT ra m a -> RemoteStoreT rb m a) mapStoreConfig f = RemoteStoreT . ( mapExceptT @@ -129,43 +120,55 @@ mapStoreConfig f = . _unRemoteStoreT -- | Ask for a @StoreDir@ -getStoreDir :: HasStoreDir r => MonadRemoteStore0 r StoreDir +getStoreDir + :: ( Monad m + , HasStoreDir r + ) + => RemoteStoreT r m StoreDir getStoreDir = hasStoreDir <$> RemoteStoreT ask -- | Ask for a @StoreDir@ -getStoreSocket :: HasStoreSocket r => MonadRemoteStore0 r Socket +getStoreSocket + :: ( Monad m + , HasStoreSocket r + ) + => RemoteStoreT r m Socket getStoreSocket = hasStoreSocket <$> RemoteStoreT ask -- | Ask for a @StoreDir@ -getProtoVersion :: HasProtoVersion r => MonadRemoteStore0 r ProtoVersion +getProtoVersion + :: ( Monad m + , HasProtoVersion r + ) + => RemoteStoreT r m ProtoVersion getProtoVersion = hasProtoVersion <$> RemoteStoreT ask -- * Logs -gotError :: MonadRemoteStore0 r Bool +gotError :: Monad m => RemoteStoreT r m Bool gotError = any isError <$> getLogs -getErrors :: MonadRemoteStore0 r [Logger] +getErrors :: Monad m => RemoteStoreT r m [Logger] getErrors = filter isError <$> getLogs -appendLogs :: [Logger] -> MonadRemoteStore0 r () +appendLogs :: Monad m => [Logger] -> RemoteStoreT r m () appendLogs x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s <> x } -getLogs :: MonadRemoteStore0 r [Logger] +getLogs :: Monad m => RemoteStoreT r m [Logger] getLogs = remoteStoreState_logs <$> RemoteStoreT get -flushLogs :: MonadRemoteStore0 r () +flushLogs :: Monad m => RemoteStoreT r m () flushLogs = RemoteStoreT $ modify $ \s -> s { remoteStoreState_logs = mempty } -- * Data required from client -getData :: MonadRemoteStore0 r (Maybe ByteString) +getData :: Monad m => RemoteStoreT r m (Maybe ByteString) getData = remoteStoreState_mData <$> RemoteStoreT get -setData :: ByteString -> MonadRemoteStore0 r () +setData :: Monad m => ByteString -> RemoteStoreT r m () setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x } -clearData :: MonadRemoteStore0 r () +clearData :: Monad m => RemoteStoreT r m () clearData = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = Nothing } 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 0ecf563..081497c 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -9,7 +9,7 @@ import Data.Serialize.Get (Get, Result(..)) import Data.Serialize.Put (Put, runPut) import Network.Socket.ByteString (recv, sendAll) import System.Nix.StorePath (HasStoreDir, StorePath) -import System.Nix.Store.Remote.MonadStore (MonadRemoteStore0, RemoteStoreError(..), getStoreDir, getStoreSocket) +import System.Nix.Store.Remote.MonadStore (RemoteStoreT, RemoteStoreError(..), getStoreDir, getStoreSocket) import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT) import System.Nix.Store.Remote.Serialize.Prim (getInt, getByteString, getByteStrings, getPath, getPathsOrFail) import System.Nix.Store.Remote.Types (HasStoreSocket(..)) @@ -34,16 +34,22 @@ genericIncremental getsome parser = do go (Fail msg _leftover) = error msg sockGet8 - :: HasStoreSocket r - => MonadRemoteStore0 r ByteString + :: ( Monad m + , MonadIO m + , HasStoreSocket r + ) + => RemoteStoreT r m ByteString sockGet8 = do soc <- getStoreSocket liftIO $ recv soc 8 sockPut - :: HasStoreSocket r + :: ( Monad m + , MonadIO m + , HasStoreSocket r + ) => Put - -> MonadRemoteStore0 r () + -> RemoteStoreT r m () sockPut p = do soc <- getStoreSocket liftIO $ sendAll soc $ runPut p @@ -93,44 +99,63 @@ sockGetS s = do -- * Obsolete getSocketIncremental - :: HasStoreSocket r + :: ( Monad m + , MonadIO m + , HasStoreSocket r + ) => Get a - -> MonadRemoteStore0 r a + -> RemoteStoreT r m a getSocketIncremental = genericIncremental sockGet8 sockGet - :: HasStoreSocket r + :: ( Monad m + , MonadIO m + , HasStoreSocket r + ) => Get a - -> MonadRemoteStore0 r a + -> RemoteStoreT r m a sockGet = getSocketIncremental sockGetInt - :: ( HasStoreSocket r + :: ( Monad m + , MonadIO m + , HasStoreSocket r , Integral a ) - => MonadRemoteStore0 r a + => RemoteStoreT r m a sockGetInt = getSocketIncremental getInt sockGetBool - :: HasStoreSocket r - => MonadRemoteStore0 r Bool + :: ( Monad m + , MonadIO m + , HasStoreSocket r + ) + => RemoteStoreT r m Bool sockGetBool = (== (1 :: Int)) <$> sockGetInt sockGetStr - :: HasStoreSocket r - => MonadRemoteStore0 r ByteString + :: ( Monad m + , MonadIO m + , HasStoreSocket r + ) + => RemoteStoreT r m ByteString sockGetStr = getSocketIncremental getByteString sockGetStrings - :: HasStoreSocket r - => MonadRemoteStore0 r [ByteString] + :: ( Monad m + , MonadIO m + , HasStoreSocket r + ) + => RemoteStoreT r m [ByteString] sockGetStrings = getSocketIncremental getByteStrings sockGetPath - :: ( HasStoreDir r + :: ( Monad m + , MonadIO m + , HasStoreDir r , HasStoreSocket r ) - => MonadRemoteStore0 r StorePath + => RemoteStoreT r m StorePath sockGetPath = do sd <- getStoreDir pth <- getSocketIncremental (getPath sd) @@ -140,10 +165,12 @@ sockGetPath = do pth sockGetPathMay - :: ( HasStoreDir r + :: ( Monad m + , MonadIO m + , HasStoreDir r , HasStoreSocket r ) - => MonadRemoteStore0 r (Maybe StorePath) + => RemoteStoreT r m (Maybe StorePath) sockGetPathMay = do sd <- getStoreDir pth <- getSocketIncremental (getPath sd) @@ -154,10 +181,12 @@ sockGetPathMay = do pth sockGetPaths - :: ( HasStoreDir r + :: ( Monad m + , MonadIO m + , HasStoreDir r , HasStoreSocket r ) - => MonadRemoteStore0 r (HashSet StorePath) + => RemoteStoreT r m (HashSet StorePath) sockGetPaths = do sd <- getStoreDir getSocketIncremental (getPathsOrFail sd) From c0a17f25a018c4b3f6daa508fe9e3e5089e0652b Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 08:36:56 +0100 Subject: [PATCH 040/104] remote: MonadRemoteStore typeclass Related to #72 Co-Authored-By: Guillaume Maudoux --- hnix-store-remote/hnix-store-remote.cabal | 2 + .../src/System/Nix/Store/Remote/Client.hs | 31 +-- .../src/System/Nix/Store/Remote/Logger.hs | 3 + .../src/System/Nix/Store/Remote/MonadStore.hs | 182 ++++++++++++------ .../src/System/Nix/Store/Remote/Socket.hs | 6 +- 5 files changed, 149 insertions(+), 75 deletions(-) diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 7d327f3..1c242cf 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -20,6 +20,7 @@ common commons ghc-options: -Wall default-extensions: DataKinds + , DefaultSignatures , DeriveGeneric , DeriveDataTypeable , DeriveFunctor @@ -34,6 +35,7 @@ common commons , ScopedTypeVariables , StandaloneDeriving , TypeApplications + , TypeOperators , TypeSynonymInstances , InstanceSigs , KindSignatures diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 857cd24..664b3a5 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -20,6 +20,7 @@ import qualified Data.Bool import qualified Data.ByteString import qualified Network.Socket.ByteString +import System.Nix.StorePath (HasStoreDir(..)) import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) @@ -32,20 +33,20 @@ import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) simpleOp - :: ( Monad m - , MonadIO m - , HasProtoVersion r + :: ( MonadIO m + , HasStoreDir r , HasStoreSocket r + , HasProtoVersion r ) => WorkerOp -> RemoteStoreT r m Bool simpleOp op = simpleOpArgs op $ pure () simpleOpArgs - :: ( Monad m - , MonadIO m - , HasProtoVersion r + :: ( MonadIO m + , HasStoreDir r , HasStoreSocket r + , HasProtoVersion r ) => WorkerOp -> Put @@ -62,20 +63,20 @@ simpleOpArgs op args = do err runOp - :: ( Monad m - , MonadIO m - , HasProtoVersion r + :: ( MonadIO m + , HasStoreDir r , HasStoreSocket r + , HasProtoVersion r ) => WorkerOp -> RemoteStoreT r m () runOp op = runOpArgs op $ pure () runOpArgs - :: ( Monad m - , MonadIO m - , HasProtoVersion r + :: ( MonadIO m + , HasStoreDir r , HasStoreSocket r + , HasProtoVersion r ) => WorkerOp -> Put @@ -86,10 +87,10 @@ runOpArgs op args = (\encode -> encode $ runPut args) runOpArgsIO - :: ( Monad m - , MonadIO m - , HasProtoVersion r + :: ( MonadIO m + , HasStoreDir r , HasStoreSocket r + , HasProtoVersion r ) => WorkerOp -> ((Data.ByteString.ByteString -> RemoteStoreT r m ()) 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 6226f29..87c32ad 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -6,6 +6,7 @@ import Control.Monad.Except (throwError) import Control.Monad.IO.Class (MonadIO) import Data.ByteString (ByteString) import Data.Serialize (Result(..)) +import System.Nix.StorePath (HasStoreDir(..)) 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) @@ -22,6 +23,7 @@ processOutput :: ( Monad m , MonadIO m , HasProtoVersion r + , HasStoreDir r , HasStoreSocket r ) => RemoteStoreT r m [Logger] @@ -41,6 +43,7 @@ processOutput = do :: ( Monad m , MonadIO m , HasProtoVersion r + , HasStoreDir r , HasStoreSocket r ) => Result (Either LoggerSError Logger) 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 82db33a..72aa6d1 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -7,20 +7,8 @@ module System.Nix.Store.Remote.MonadStore , RemoteStoreT , runRemoteStoreT , mapStoreConfig - -- * Reader helpers - , getStoreDir - , getStoreSocket + , MonadRemoteStore(..) , getProtoVersion - -- * Logs - , appendLogs - , getLogs - , flushLogs - , gotError - , getErrors - -- * Data required from client - , getData - , setData - , clearData ) where import Control.Monad.Except (MonadError) @@ -119,21 +107,131 @@ mapStoreConfig f = ) f . _unRemoteStoreT --- | Ask for a @StoreDir@ -getStoreDir - :: ( Monad m - , HasStoreDir r - ) - => RemoteStoreT r m StoreDir -getStoreDir = hasStoreDir <$> RemoteStoreT ask +class ( Monad m + , MonadError RemoteStoreError m + ) + => MonadRemoteStore m where --- | Ask for a @StoreDir@ -getStoreSocket - :: ( Monad m - , HasStoreSocket r - ) - => RemoteStoreT r m Socket -getStoreSocket = hasStoreSocket <$> RemoteStoreT ask + appendLogs :: [Logger] -> m () + default appendLogs + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => [Logger] + -> m () + appendLogs = lift . appendLogs + + gotError :: m Bool + default gotError + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m Bool + gotError = lift gotError + + getErrors :: m [Logger] + default getErrors + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m [Logger] + getErrors = lift getErrors + + getLogs :: m [Logger] + default getLogs + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m [Logger] + getLogs = lift getLogs + + flushLogs :: m () + default flushLogs + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m () + flushLogs = lift flushLogs + + setData :: ByteString -> m () + default setData + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => ByteString + -> m () + setData = lift . setData + + getData :: m (Maybe ByteString) + default getData + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m (Maybe ByteString) + getData = lift getData + + clearData :: m () + default clearData + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m () + clearData = lift clearData + + getStoreDir :: m StoreDir + default getStoreDir + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m StoreDir + getStoreDir = lift getStoreDir + + getStoreSocket :: m Socket + default getStoreSocket + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m Socket + getStoreSocket = lift getStoreSocket + +instance MonadRemoteStore m => MonadRemoteStore (StateT s m) +instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m) +instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m) + +instance ( Monad m + , HasStoreDir r + , HasStoreSocket r + ) + => MonadRemoteStore (RemoteStoreT r m) where + + getStoreDir = hasStoreDir <$> RemoteStoreT ask + getStoreSocket = hasStoreSocket <$> RemoteStoreT ask + + appendLogs x = + RemoteStoreT + $ modify + $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s <> x } + getLogs = remoteStoreState_logs <$> RemoteStoreT get + flushLogs = + RemoteStoreT + $ modify + $ \s -> s { remoteStoreState_logs = mempty } + gotError = any isError <$> getLogs + getErrors = filter isError <$> getLogs + + getData = remoteStoreState_mData <$> RemoteStoreT get + setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x } + clearData = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = Nothing } -- | Ask for a @StoreDir@ getProtoVersion @@ -142,33 +240,3 @@ getProtoVersion ) => RemoteStoreT r m ProtoVersion getProtoVersion = hasProtoVersion <$> RemoteStoreT ask - --- * Logs - -gotError :: Monad m => RemoteStoreT r m Bool -gotError = any isError <$> getLogs - -getErrors :: Monad m => RemoteStoreT r m [Logger] -getErrors = filter isError <$> getLogs - -appendLogs :: Monad m => [Logger] -> RemoteStoreT r m () -appendLogs x = RemoteStoreT - $ modify - $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s <> x } - -getLogs :: Monad m => RemoteStoreT r m [Logger] -getLogs = remoteStoreState_logs <$> RemoteStoreT get - -flushLogs :: Monad m => RemoteStoreT r m () -flushLogs = RemoteStoreT $ modify $ \s -> s { remoteStoreState_logs = mempty } - --- * Data required from client - -getData :: Monad m => RemoteStoreT r m (Maybe ByteString) -getData = remoteStoreState_mData <$> RemoteStoreT get - -setData :: Monad m => ByteString -> RemoteStoreT r m () -setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x } - -clearData :: Monad m => RemoteStoreT r m () -clearData = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = Nothing } 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 081497c..8e33264 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -9,7 +9,7 @@ import Data.Serialize.Get (Get, Result(..)) import Data.Serialize.Put (Put, runPut) import Network.Socket.ByteString (recv, sendAll) import System.Nix.StorePath (HasStoreDir, StorePath) -import System.Nix.Store.Remote.MonadStore (RemoteStoreT, RemoteStoreError(..), getStoreDir, getStoreSocket) +import System.Nix.Store.Remote.MonadStore (RemoteStoreT, RemoteStoreError(..), getStoreDir) import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT) import System.Nix.Store.Remote.Serialize.Prim (getInt, getByteString, getByteStrings, getPath, getPathsOrFail) import System.Nix.Store.Remote.Types (HasStoreSocket(..)) @@ -40,7 +40,7 @@ sockGet8 ) => RemoteStoreT r m ByteString sockGet8 = do - soc <- getStoreSocket + soc <- asks hasStoreSocket liftIO $ recv soc 8 sockPut @@ -51,7 +51,7 @@ sockPut => Put -> RemoteStoreT r m () sockPut p = do - soc <- getStoreSocket + soc <- asks hasStoreSocket liftIO $ sendAll soc $ runPut p sockPutS From a39ee890d01f7bfe7d8132b06f3d35c3e7863f2c Mon Sep 17 00:00:00 2001 From: sorki Date: Sat, 2 Dec 2023 17:32:13 +0100 Subject: [PATCH 041/104] remote: init Remote.Server --- hnix-store-remote/hnix-store-remote.cabal | 2 + .../src/System/Nix/Store/Remote/MonadStore.hs | 14 + .../src/System/Nix/Store/Remote/Server.hs | 374 ++++++++++++++++++ 3 files changed, 390 insertions(+) create mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Server.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 1c242cf..e41b03a 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -83,6 +83,7 @@ library , System.Nix.Store.Remote.Serialize , System.Nix.Store.Remote.Serialize.Prim , System.Nix.Store.Remote.Serializer + , System.Nix.Store.Remote.Server , System.Nix.Store.Remote.Socket , System.Nix.Store.Remote.Types , System.Nix.Store.Remote.Types.Activity @@ -111,6 +112,7 @@ library , bytestring , cereal , containers + , concurrency , crypton , data-default-class , dependent-sum > 0.7 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 72aa6d1..84abc10 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -4,6 +4,7 @@ module System.Nix.Store.Remote.MonadStore ( RemoteStoreState(..) , RemoteStoreError(..) , WorkerError(..) + , WorkerException(..) , RemoteStoreT , runRemoteStoreT , mapStoreConfig @@ -47,13 +48,26 @@ data RemoteStoreError | RemoteStoreError_ProtocolMismatch | RemoteStoreError_WorkerMagic2Mismatch | RemoteStoreError_WorkerError WorkerError + -- bad / redundant + | RemoteStoreError_WorkerException WorkerException deriving (Eq, Show, Ord) +-- | fatal error in worker interaction which should disconnect client. +data WorkerException + = WorkerException_ClientVersionTooOld + | WorkerException_ProtocolMismatch + | WorkerException_Error WorkerError + -- ^ allowed error outside allowed worker state +-- | WorkerException_DecodingError DecodingError +-- | WorkerException_BuildFailed StorePath + deriving (Eq, Ord, Show) + -- | Non-fatal (to server) errors in worker interaction data WorkerError = WorkerError_SendClosed | WorkerError_InvalidOperation Word64 | WorkerError_NotYetImplemented + | WorkerError_UnsupportedOperation deriving (Eq, Ord, Show) newtype RemoteStoreT r m a = RemoteStoreT diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs new file mode 100644 index 0000000..94ba7e6 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +module System.Nix.Store.Remote.Server 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.Foldable (traverse_) +import Data.IORef (IORef, atomicModifyIORef, newIORef) +import Data.Some (Some(Some)) +import Data.Text (Text) +import Data.Void (Void, absurd) +import Data.Word (Word32) +import qualified Data.Text +import qualified Data.Text.IO +import Network.Socket (Socket, accept, close, listen, maxListenQueue) +import System.Nix.StorePath (StoreDir) +import System.Nix.Store.Remote.Serializer as RB +import System.Nix.Store.Remote.Socket +import System.Nix.Store.Remote.Types.StoreRequest as R +import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig(..), PreStoreConfig(..), preStoreConfigToStoreConfig) +import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..)) +import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..)) + +import System.Nix.Store.Remote.MonadStore (WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT, mapStoreConfig) +import System.Nix.Store.Remote.Types.Handshake (Handshake(..)) +import System.Nix.Store.Remote.Types.ProtoVersion (ourProtoVersion) +import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) + +type WorkerHelper m = forall a. StoreRequest a -> m a + +-- | Run an emulated nix daemon on given socket address. +-- The deamon will close when the continuation returns. +runDaemonSocket + :: forall m a + . ( MonadIO m + , MonadConc m + , MonadError RemoteStoreError m + , MonadReader StoreConfig m + ) + => StoreDir + -> WorkerHelper m + -> Socket + -> m a + -> m a +runDaemonSocket sd workerHelper lsock k = do + liftIO $ listen lsock maxListenQueue + + liftIO $ Data.Text.IO.putStrLn "listening" + + let listener :: m Void + listener = do + (sock, _) <- liftIO $ accept lsock + liftIO $ Data.Text.IO.putStrLn "accepting" + + let preStoreConfig = PreStoreConfig + { preStoreConfig_socket = sock + , preStoreConfig_dir = sd + } + + -- TODO: this, but without the space leak + fmap fst $ concurrently listener $ processConnection workerHelper preStoreConfig + + either absurd id <$> race listener k + +-- | "main loop" of the daemon for a single connection. +-- +-- this function should take care to not throw errors from client connections. +processConnection + :: ( MonadIO m + , MonadError RemoteStoreError m + , MonadReader StoreConfig m + ) + => WorkerHelper m + -> PreStoreConfig + -> m () +processConnection workerHelper preStoreConfig = do + let handshake = Handshake + { handshakeNixVersion = Just "nixVersion (hnix-store-remote)" + , handshakeTrust = Nothing + -- TODO: doesn't make sense for server + , handshakeProtoVersion = ourProtoVersion + -- TODO: doesn't make sense for server + , handshakeRemoteProtoVersion = ourProtoVersion + -- TODO: try this + , handshakeLogs = mempty + } + + ~() <- void $ runRemoteStoreT preStoreConfig $ do + + minimumCommonVersion <- greet handshake + + mapStoreConfig + (preStoreConfigToStoreConfig minimumCommonVersion) + $ do + + tunnelLogger <- liftIO $ newTunnelLogger + -- Send startup error messages to the client. + startWork tunnelLogger + + -- TODO: do we need auth at all? probably? + -- If we can't accept clientVersion, then throw an error *here* (not above). + --authHook(*store); + stopWork tunnelLogger + + -- Process client requests. + let loop = do + someReq <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerGet + storeRequest + + lift $ performOp' workerHelper tunnelLogger someReq + loop + loop + + liftIO $ Data.Text.IO.putStrLn "daemon connection done" + liftIO $ close $ preStoreConfig_socket preStoreConfig + + where + -- Exchange the greeting. + greet + :: MonadIO m + => Handshake + -> RemoteStoreT PreStoreConfig m ProtoVersion + greet Handshake{..} = do + magic <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + + liftIO $ print ("magic" :: Text, magic) + when (magic /= WorkerMagic_One) + $ throwError $ RemoteStoreError_WorkerException WorkerException_ProtocolMismatch + + sockPutS + (mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + ) + WorkerMagic_Two + + sockPutS protoVersion ourProtoVersion + + clientVersion <- sockGetS protoVersion + + let minimumCommonVersion = min clientVersion ourProtoVersion + + liftIO $ print ("Versions client, min" :: Text, clientVersion, minimumCommonVersion) + + when (clientVersion < ProtoVersion 1 10) + $ throwError + $ RemoteStoreError_WorkerException + WorkerException_ClientVersionTooOld + + when (clientVersion >= ProtoVersion 1 14) $ do + x :: Word32 <- sockGetS int + when (x /= 0) $ do + -- Obsolete CPU affinity. + _ :: Word32 <- sockGetS int + pure () + + when (clientVersion >= ProtoVersion 1 11) $ do + _ :: Word32 <- sockGetS int -- obsolete reserveSpace + pure () + + when (clientVersion >= ProtoVersion 1 33) $ do + sockPutS + (mapErrorS + RemoteStoreError_SerializerPut + text + ) + -- TODO + (maybe undefined id handshakeNixVersion) + + when (clientVersion >= ProtoVersion 1 35) $ do + sockPutS + (mapErrorS + RemoteStoreError_SerializerHandshake + trustedFlag + ) + handshakeTrust + + pure minimumCommonVersion + +simpleOp + :: ( MonadIO m + , HasStoreSocket r + , HasProtoVersion r + , MonadError RemoteStoreError m + , MonadReader r m + ) + => (StoreRequest () -> m ()) + -> TunnelLogger r + -> m (StoreRequest ()) + -> m () +simpleOp workerHelper tunnelLogger m = do + req <- m + bracketLogger tunnelLogger $ workerHelper req + sockPutS + (mapErrorS + RemoteStoreError_SerializerPut + bool + ) + True + +simpleOpRet + :: ( MonadIO m + , HasStoreSocket r + , HasProtoVersion r + , MonadError RemoteStoreError m + , MonadReader r m + ) + => (StoreRequest a -> m a) + -> TunnelLogger r + -> NixSerializer r SError a + -> m (StoreRequest a) + -> m () +simpleOpRet workerHelper tunnelLogger s m = do + req <- m + resp <- bracketLogger tunnelLogger $ workerHelper req + sockPutS + (mapErrorS + RemoteStoreError_SerializerPut + s + ) + resp + +bracketLogger + :: ( MonadIO m + , HasStoreSocket r + , HasProtoVersion r + , MonadReader r m + , MonadError RemoteStoreError m + ) + => TunnelLogger r + -> m a + -> m a +bracketLogger tunnelLogger m = do + startWork tunnelLogger + a <- m + stopWork tunnelLogger + pure a + +{-# WARNING unimplemented "not yet implemented" #-} +unimplemented :: WorkerException +unimplemented = WorkerException_Error $ WorkerError_NotYetImplemented + +performOp' + :: forall m + . ( MonadIO m + , MonadError RemoteStoreError m + , MonadReader StoreConfig m + ) + => WorkerHelper m + -> TunnelLogger StoreConfig + -> Some StoreRequest + -> m () +performOp' workerHelper tunnelLogger op = do + let _simpleOp' = simpleOp workerHelper tunnelLogger + let simpleOpRet' + :: NixSerializer StoreConfig SError a + -> m (StoreRequest a) + -> m () + simpleOpRet' = simpleOpRet workerHelper tunnelLogger + + case op of + Some (IsValidPath path) -> simpleOpRet' bool $ do + pure $ R.IsValidPath path + + _ -> undefined + +--- + +data TunnelLogger r = TunnelLogger + { _tunnelLogger_state :: IORef (TunnelLoggerState r) + } + +data TunnelLoggerState r = TunnelLoggerState + { _tunnelLoggerState_canSendStderr :: Bool + , _tunnelLoggerState_pendingMsgs :: [Logger] + } + +newTunnelLogger :: IO (TunnelLogger r) +newTunnelLogger = TunnelLogger <$> newIORef (TunnelLoggerState False []) + +enqueueMsg + :: ( MonadIO m + , MonadReader r m + , MonadError LoggerSError m + , HasProtoVersion r + , HasStoreSocket r + ) + => TunnelLogger r + -> Logger + -> m () +enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of + True -> (st, sockPutS logger l) + False -> (TunnelLoggerState c (l:p), pure ()) + +log + :: ( MonadIO m + , MonadReader r m + , HasStoreSocket r + , MonadError LoggerSError m + , HasProtoVersion r + ) + => TunnelLogger r + -> Text + -> m () +log l s = enqueueMsg l (Logger_Next s) + +startWork + :: (MonadIO m, MonadReader r m, HasStoreSocket r + + , MonadError RemoteStoreError m + , HasProtoVersion r + ) + => TunnelLogger r + -> m () +startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,) + (TunnelLoggerState True []) $ + (traverse_ (sockPutS logger') $ reverse p) + where logger' = mapErrorS RemoteStoreError_SerializerLogger logger + +stopWork + :: (MonadIO m, MonadReader r m, HasStoreSocket r + + , MonadError RemoteStoreError m + , HasProtoVersion r + ) + => TunnelLogger r + -> m () +stopWork x = updateLogger x $ \_ -> (,) + (TunnelLoggerState False []) + (sockPutS (mapErrorS RemoteStoreError_SerializerLogger logger) Logger_Last) + +-- | Stop sending logging and report an error. +-- +-- Returns true if the the session was in a state that allowed the error to be +-- sent. +-- +-- Unlike 'stopWork', this function may be called at any time to (try) to end a +-- session with an error. +stopWorkOnError + :: (MonadIO m, MonadReader r m, HasStoreSocket r, HasProtoVersion r + + , MonadError RemoteStoreError m + ) + => TunnelLogger r + -> ErrorInfo + -> m Bool +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 + then sockPutS logger' (Logger_Error (Right ex)) + else sockPutS logger' (Logger_Error (Left (BasicError 0 (Data.Text.pack $ show ex)))) + pure True + where logger' = mapErrorS RemoteStoreError_SerializerLogger logger + +updateLogger + :: (MonadIO m, MonadReader r m, HasStoreSocket r) + => TunnelLogger r + -> (TunnelLoggerState r -> (TunnelLoggerState r, m a)) + -> m a +updateLogger x = join . liftIO . atomicModifyIORef (_tunnelLogger_state x) From 9b6637347183366d39cf792993e4323b83cfeb7e Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 12:05:24 +0100 Subject: [PATCH 042/104] remote: fix arbitrary repair mode of AddToStore AddTextToStore to DontRepair --- hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index e5869b5..56e39b1 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -5,6 +5,7 @@ module System.Nix.Store.Remote.Arbitrary where import Data.Some (Some(Some)) import System.Nix.Arbitrary () +import System.Nix.Store.Types (RepairMode(..)) import System.Nix.Store.Remote.Types import Test.QuickCheck (Arbitrary(..), oneof, suchThat) @@ -95,8 +96,8 @@ deriving via GenericArbitrary WorkerOp instance Arbitrary (Some StoreRequest) where arbitrary = oneof - [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) - , Some <$> (AddTextToStore <$> arbitrary <*> arbitrary <*> arbitrary) + [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair) + , Some <$> (AddTextToStore <$> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair) , Some <$> (AddSignatures <$> arbitrary <*> arbitrary) , Some . AddIndirectRoot <$> arbitrary , Some . AddTempRoot <$> arbitrary From 11a9bfffd095963f0f16637692cd239c3c3e589f Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 12:07:38 +0100 Subject: [PATCH 043/104] remote: align AddToStore and AddTextToStore serializers with old versions --- .../src/System/Nix/Store/Remote/Serializer.hs | 31 ++++++++++++------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 63816c3..fe49852 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -117,8 +117,9 @@ import System.Nix.Build (BuildMode, BuildResult(..)) import System.Nix.ContentAddress (ContentAddress) import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) import System.Nix.DerivedPath (DerivedPath, ParseOutputsError) -import System.Nix.Hash (HashAlgo) +import System.Nix.Hash (HashAlgo(..)) import System.Nix.Signature (Signature, NarSignature) +import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) import System.Nix.StorePath (HasStoreDir(..), InvalidPathError, StorePath, StorePathHashPart, StorePathName) import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) import System.Nix.Store.Remote.Types @@ -984,16 +985,20 @@ storeRequest = Serializer { getS = getS workerOp >>= \case WorkerOp_AddToStore -> do pathName <- getS storePathName + _fixed <- getS bool -- obsolete recursive <- getS enum hashAlgo <- getS someHashAlgo - repairMode <- getS enum - pure $ Some (AddToStore pathName recursive hashAlgo repairMode) + + -- not supported by ProtoVersion < 1.25 + let repair = RepairMode_DontRepair + + pure $ Some (AddToStore pathName recursive hashAlgo repair) WorkerOp_AddTextToStore -> do txt <- getS storeText paths <- getS (hashSet storePath) - repairMode <- getS enum - pure $ Some (AddTextToStore txt paths repairMode) + let repair = RepairMode_DontRepair + pure $ Some (AddTextToStore txt paths repair) WorkerOp_AddSignatures -> do path <- getS storePath @@ -1106,20 +1111,24 @@ storeRequest = Serializer WorkerOp_SetOptions -> undefined , putS = \case - Some (AddToStore pathName recursive hashAlgo repairMode) -> do + Some (AddToStore pathName recursive hashAlgo _repair) -> do putS workerOp WorkerOp_AddToStore putS storePathName pathName - putS enum recursive - putS someHashAlgo hashAlgo - putS enum repairMode + -- obsolete fixed + putS bool + $ not + $ hashAlgo == Some HashAlgo_SHA256 + && (recursive == FileIngestionMethod_FileRecursive) - Some (AddTextToStore txt paths repairMode) -> do + putS bool (recursive == FileIngestionMethod_FileRecursive) + putS someHashAlgo hashAlgo + + Some (AddTextToStore txt paths _repair) -> do putS workerOp WorkerOp_AddTextToStore putS storeText txt putS (hashSet storePath) paths - putS enum repairMode Some (AddSignatures path signatures) -> do putS workerOp WorkerOp_AddSignatures From 638ac9ea80a97e3ef086d56f82a9abce355dc0f6 Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 12:14:55 +0100 Subject: [PATCH 044/104] remote: fix dumm(p)y path typo --- hnix-store-remote/tests-io/NixDaemon.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index a0dc825..1088cc0 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemon.hs @@ -159,7 +159,7 @@ withPath action = do path <- addTextToStore "hnix-store" "test" mempty RepairMode_DontRepair action path --- | dummy path, adds /dummpy with "Hello World" contents +-- | dummy path, adds /dummy with "Hello World" contents dummy :: MonadStore StorePath dummy = do let name = Data.Either.fromRight (error "impossible") $ makeStorePathName "dummy" From 0c54337dbf801f9190a6473103228e509c926fbb Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 12:17:35 +0100 Subject: [PATCH 045/104] remote: add NarSource to RemoteStoreState, add setNarSource, takeNarSource to MonadRemoteStore --- .../src/System/Nix/Store/Remote/MonadStore.hs | 31 ++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) 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 84abc10..67d17ff 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -23,6 +23,7 @@ import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT) import Data.ByteString (ByteString) import Data.Word (Word64) import Network.Socket (Socket) +import System.Nix.Nar (NarSource) import System.Nix.StorePath (HasStoreDir(..), StoreDir) import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, SError) import System.Nix.Store.Remote.Types.Logger (Logger, isError) @@ -32,7 +33,8 @@ import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..)) data RemoteStoreState = RemoteStoreState { remoteStoreState_logs :: [Logger] , remoteStoreState_mData :: Maybe ByteString - } deriving (Eq, Ord, Show) + , remoteStoreState_mNarSource :: Maybe (NarSource IO) + } data RemoteStoreError = RemoteStoreError_Fixme String @@ -45,6 +47,7 @@ data RemoteStoreError | RemoteStoreError_SerializerLogger LoggerSError | RemoteStoreError_SerializerPut SError | RemoteStoreError_NoDataProvided + | RemoteStoreError_NoNarSourceProvided | RemoteStoreError_ProtocolMismatch | RemoteStoreError_WorkerMagic2Mismatch | RemoteStoreError_WorkerError WorkerError @@ -108,6 +111,7 @@ runRemoteStoreT r = emptyState = RemoteStoreState { remoteStoreState_logs = mempty , remoteStoreState_mData = Nothing + , remoteStoreState_mNarSource = Nothing } mapStoreConfig @@ -218,6 +222,25 @@ class ( Monad m => m Socket getStoreSocket = lift getStoreSocket + setNarSource :: NarSource IO -> m () + default setNarSource + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => NarSource IO + -> m () + setNarSource x = lift (setNarSource x) + + takeNarSource :: m (Maybe (NarSource IO)) + default takeNarSource + :: ( MonadTrans t + , MonadRemoteStore m' + , m ~ t m' + ) + => m (Maybe (NarSource IO)) + takeNarSource = lift takeNarSource + instance MonadRemoteStore m => MonadRemoteStore (StateT s m) instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m) instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m) @@ -247,6 +270,12 @@ instance ( Monad m setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x } clearData = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = Nothing } + setNarSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mNarSource = pure x } + takeNarSource = RemoteStoreT $ do + x <- remoteStoreState_mNarSource <$> get + modify $ \s -> s { remoteStoreState_mNarSource = Nothing } + pure x + -- | Ask for a @StoreDir@ getProtoVersion :: ( Monad m From c25a5a8535e104ae118244cdd7f647c7e3d107e3 Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 12:18:26 +0100 Subject: [PATCH 046/104] remote: init Remote.Client.doReq --- .../src/System/Nix/Store/Remote/Client.hs | 77 ++++++++++++++++++- .../src/System/Nix/Store/Remote/MonadStore.hs | 1 + 2 files changed, 76 insertions(+), 2 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 664b3a5..83a5a8e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -9,29 +9,41 @@ module System.Nix.Store.Remote.Client , runOpArgsIO , runStoreSocket , ourProtoVersion + , doReq + , addToStore + , isValidPath ) where import Control.Monad (unless, when) import Control.Monad.Except (throwError) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Serialize.Put (Put, runPut) +import Data.Some (Some(Some)) import qualified Data.Bool import qualified Data.ByteString import qualified Network.Socket.ByteString -import System.Nix.StorePath (HasStoreDir(..)) +import System.Nix.Nar (NarSource) +import System.Nix.StorePath (HasStoreDir(..), StorePath) import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) -import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, text, trustedFlag, workerMagic) +--import System.Nix.Store.Remote.Serializer (NixSerializer, SError, bool, enum, int, mapErrorS, protoVersion, storeRequest, text, trustedFlag, workerMagic) +import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.Handshake (Handshake(..)) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion, ProtoVersion(..), ourProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket, PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) +import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) +-- WIP ops +import System.Nix.Hash (HashAlgo(..)) +import System.Nix.StorePath (StorePathName) +import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) + simpleOp :: ( MonadIO m , HasStoreDir r @@ -110,6 +122,67 @@ runOpArgsIO op encoder = do -- TODO: don't use show getErrors >>= throwError . RemoteStoreError_Fixme . show +doReq + :: ( MonadIO m + , StoreReply a + ) + => StoreRequest a + -> RemoteStoreT StoreConfig m a +doReq = \case + x -> do + sockPutS (mapErrorS RemoteStoreError_SerializerPut storeRequest) (Some x) + case x of + AddToStore {} -> do + + ms <- takeNarSource + case ms of + Just (stream :: NarSource IO) -> do + soc <- getStoreSocket + liftIO $ stream $ Network.Socket.ByteString.sendAll soc + Nothing -> throwError RemoteStoreError_NoNarSourceProvided + + _ -> pure () + out <- processOutput + appendLogs out + sockGetS (mapErrorS RemoteStoreError_SerializerGet getReply) + +class StoreReply a where + getReply + :: ( HasStoreDir r + , HasProtoVersion r + ) + => NixSerializer r SError a + +instance StoreReply Bool where + getReply = bool + +instance StoreReply StorePath where + getReply = storePath + +-- | Pack `Nar` and add it to the store. +addToStore + :: MonadIO m + => StorePathName -- ^ Name part of the newly created `StorePath` + -> NarSource IO -- ^ Provide nar stream + -> FileIngestionMethod -- ^ Add target directory recursively + -> Some HashAlgo -- ^ + -> RepairMode -- ^ Only used by local store backend + -> RemoteStoreT StoreConfig m StorePath +addToStore name source method hashAlgo repair = do + Control.Monad.when + (repair == RepairMode_DoRepair) + $ throwError RemoteStoreError_RapairNotSupportedByRemoteStore + + setNarSource source + doReq (AddToStore name method hashAlgo repair) + +isValidPath :: MonadIO m => StorePath -> RemoteStoreT StoreConfig m Bool +isValidPath = doReq . IsValidPath + +-- TOOD: want this, but Logger.processOutput is fixed to RemoteStoreT r m +--isValidPath' :: MonadRemoteStore m => StorePath -> m Bool +--isValidPath' = doReq . IsValidPath + type Run m a = m (Either RemoteStoreError a, [Logger]) runStoreSocket 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 67d17ff..716c6de 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -49,6 +49,7 @@ data RemoteStoreError | RemoteStoreError_NoDataProvided | RemoteStoreError_NoNarSourceProvided | RemoteStoreError_ProtocolMismatch + | RemoteStoreError_RapairNotSupportedByRemoteStore -- "repairing is not supported when building through the Nix daemon" | RemoteStoreError_WorkerMagic2Mismatch | RemoteStoreError_WorkerError WorkerError -- bad / redundant From a934eb1e198709f93715162b359eb310f1a9be4a Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 12:59:42 +0100 Subject: [PATCH 047/104] remote: MonadRemoteStoreR --- .../src/System/Nix/Store/Remote/Client.hs | 38 +++++++++----- .../src/System/Nix/Store/Remote/MonadStore.hs | 49 +++++++++++-------- 2 files changed, 53 insertions(+), 34 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 83a5a8e..4a607ec 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -17,6 +17,7 @@ module System.Nix.Store.Remote.Client import Control.Monad (unless, when) import Control.Monad.Except (throwError) import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (ask) import Data.Serialize.Put (Put, runPut) import Data.Some (Some(Some)) @@ -123,14 +124,19 @@ runOpArgsIO op encoder = do getErrors >>= throwError . RemoteStoreError_Fixme . show doReq - :: ( MonadIO m + :: forall m r a + . ( MonadIO m + , MonadRemoteStoreR r m + , HasProtoVersion r , StoreReply a ) => StoreRequest a - -> RemoteStoreT StoreConfig m a + -> m a doReq = \case x -> do - sockPutS (mapErrorS RemoteStoreError_SerializerPut storeRequest) (Some x) + cfg <- ask + _ <- runRemoteStoreT cfg $ + sockPutS (mapErrorS RemoteStoreError_SerializerPut storeRequest) (Some x) case x of AddToStore {} -> do @@ -142,9 +148,15 @@ doReq = \case Nothing -> throwError RemoteStoreError_NoNarSourceProvided _ -> pure () - out <- processOutput - appendLogs out - sockGetS (mapErrorS RemoteStoreError_SerializerGet getReply) + + _ <- either (throwError @RemoteStoreError @m) appendLogs . fst <$> runRemoteStoreT cfg processOutput + --either throwError pure . fst <$> runRemoteStoreT cfg $ + eres <- runRemoteStoreT cfg $ + sockGetS (mapErrorS RemoteStoreError_SerializerGet (getReply @a)) + + case eres of + (Left e, _logs) -> throwError e + (Right res, _logs) -> pure res class StoreReply a where getReply @@ -159,15 +171,15 @@ instance StoreReply Bool where instance StoreReply StorePath where getReply = storePath --- | Pack `Nar` and add it to the store. +-- | Add `NarSource` to the store addToStore - :: MonadIO m + :: MonadRemoteStore m => StorePathName -- ^ Name part of the newly created `StorePath` -> NarSource IO -- ^ Provide nar stream -> FileIngestionMethod -- ^ Add target directory recursively -> Some HashAlgo -- ^ -> RepairMode -- ^ Only used by local store backend - -> RemoteStoreT StoreConfig m StorePath + -> m StorePath addToStore name source method hashAlgo repair = do Control.Monad.when (repair == RepairMode_DoRepair) @@ -176,12 +188,12 @@ addToStore name source method hashAlgo repair = do setNarSource source doReq (AddToStore name method hashAlgo repair) -isValidPath :: MonadIO m => StorePath -> RemoteStoreT StoreConfig m Bool -isValidPath = doReq . IsValidPath +--isValidPath :: MonadIO m => StorePath -> RemoteStoreT StoreConfig m Bool +--isValidPath = doReq . IsValidPath -- TOOD: want this, but Logger.processOutput is fixed to RemoteStoreT r m ---isValidPath' :: MonadRemoteStore m => StorePath -> m Bool ---isValidPath' = doReq . IsValidPath +isValidPath :: MonadRemoteStore m => StorePath -> m Bool +isValidPath = doReq . IsValidPath type Run m a = m (Either RemoteStoreError a, [Logger]) 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 716c6de..f2856b0 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module System.Nix.Store.Remote.MonadStore @@ -8,7 +9,8 @@ module System.Nix.Store.Remote.MonadStore , RemoteStoreT , runRemoteStoreT , mapStoreConfig - , MonadRemoteStore(..) + , MonadRemoteStoreR(..) + , MonadRemoteStore , getProtoVersion ) where @@ -28,7 +30,7 @@ import System.Nix.StorePath (HasStoreDir(..), StoreDir) import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, SError) import System.Nix.Store.Remote.Types.Logger (Logger, isError) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion) -import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..)) +import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig) data RemoteStoreState = RemoteStoreState { remoteStoreState_logs :: [Logger] @@ -126,15 +128,18 @@ mapStoreConfig f = ) f . _unRemoteStoreT -class ( Monad m +class ( MonadIO m , MonadError RemoteStoreError m + , HasStoreSocket r + , HasStoreDir r + , MonadReader r m ) - => MonadRemoteStore m where + => MonadRemoteStoreR r m where appendLogs :: [Logger] -> m () default appendLogs :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => [Logger] @@ -144,7 +149,7 @@ class ( Monad m gotError :: m Bool default gotError :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => m Bool @@ -153,7 +158,7 @@ class ( Monad m getErrors :: m [Logger] default getErrors :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => m [Logger] @@ -162,7 +167,7 @@ class ( Monad m getLogs :: m [Logger] default getLogs :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => m [Logger] @@ -171,7 +176,7 @@ class ( Monad m flushLogs :: m () default flushLogs :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => m () @@ -180,7 +185,7 @@ class ( Monad m setData :: ByteString -> m () default setData :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => ByteString @@ -190,7 +195,7 @@ class ( Monad m getData :: m (Maybe ByteString) default getData :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => m (Maybe ByteString) @@ -199,7 +204,7 @@ class ( Monad m clearData :: m () default clearData :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => m () @@ -208,7 +213,7 @@ class ( Monad m getStoreDir :: m StoreDir default getStoreDir :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => m StoreDir @@ -217,7 +222,7 @@ class ( Monad m getStoreSocket :: m Socket default getStoreSocket :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => m Socket @@ -226,7 +231,7 @@ class ( Monad m setNarSource :: NarSource IO -> m () default setNarSource :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => NarSource IO @@ -236,21 +241,23 @@ class ( Monad m takeNarSource :: m (Maybe (NarSource IO)) default takeNarSource :: ( MonadTrans t - , MonadRemoteStore m' + , MonadRemoteStoreR r m' , m ~ t m' ) => m (Maybe (NarSource IO)) takeNarSource = lift takeNarSource -instance MonadRemoteStore m => MonadRemoteStore (StateT s m) -instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m) -instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m) +instance MonadRemoteStoreR r m => MonadRemoteStoreR r (StateT s m) +instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ReaderT r m) +instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ExceptT RemoteStoreError m) -instance ( Monad m +type MonadRemoteStore m = MonadRemoteStoreR StoreConfig m + +instance ( MonadIO m , HasStoreDir r , HasStoreSocket r ) - => MonadRemoteStore (RemoteStoreT r m) where + => MonadRemoteStoreR r (RemoteStoreT r m) where getStoreDir = hasStoreDir <$> RemoteStoreT ask getStoreSocket = hasStoreSocket <$> RemoteStoreT ask From 001f4cad7a03416bdb2348be4990c6335bb7f642 Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 14:04:07 +0100 Subject: [PATCH 048/104] remote: deal with logger, tagless --- .../src/System/Nix/Store/Remote/Client.hs | 83 ++++++------------- .../src/System/Nix/Store/Remote/Logger.hs | 55 ++++++------ .../src/System/Nix/Store/Remote/MonadStore.hs | 81 ++++++++---------- .../src/System/Nix/Store/Remote/Server.hs | 2 - .../src/System/Nix/Store/Remote/Socket.hs | 81 ++++++------------ .../Nix/Store/Remote/Types/Handshake.hs | 2 - 6 files changed, 114 insertions(+), 190 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 4a607ec..4cba45e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -21,7 +21,6 @@ import Control.Monad.Reader (ask) import Data.Serialize.Put (Put, runPut) import Data.Some (Some(Some)) -import qualified Data.Bool import qualified Data.ByteString import qualified Network.Socket.ByteString @@ -35,7 +34,7 @@ import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.Handshake (Handshake(..)) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion, ProtoVersion(..), ourProtoVersion) -import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket, PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) +import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) @@ -46,88 +45,58 @@ import System.Nix.StorePath (StorePathName) import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) simpleOp - :: ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - , HasProtoVersion r - ) + :: MonadRemoteStore m => WorkerOp - -> RemoteStoreT r m Bool + -> m Bool simpleOp op = simpleOpArgs op $ pure () simpleOpArgs - :: ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - , HasProtoVersion r - ) + :: MonadRemoteStore m => WorkerOp -> Put - -> RemoteStoreT r m Bool + -> m Bool simpleOpArgs op args = do runOpArgs op args - err <- gotError - Data.Bool.bool - (sockGetS $ mapErrorS RemoteStoreError_SerializerGet bool) - (do - -- TODO: don't use show - getErrors >>= throwError . RemoteStoreError_Fixme . show - ) - err + errored <- gotError + if errored + then throwError RemoteStoreError_OperationFailed + else sockGetS $ mapErrorS RemoteStoreError_SerializerGet bool runOp - :: ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - , HasProtoVersion r - ) + :: MonadRemoteStore m => WorkerOp - -> RemoteStoreT r m () + -> m () runOp op = runOpArgs op $ pure () runOpArgs - :: ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - , HasProtoVersion r - ) + :: MonadRemoteStore m => WorkerOp -> Put - -> RemoteStoreT r m () + -> m () runOpArgs op args = runOpArgsIO op (\encode -> encode $ runPut args) runOpArgsIO - :: ( MonadIO m - , HasStoreDir r - , HasStoreSocket r - , HasProtoVersion r - ) + :: MonadRemoteStore m => WorkerOp - -> ((Data.ByteString.ByteString -> RemoteStoreT r m ()) - -> RemoteStoreT r m () + -> ((Data.ByteString.ByteString -> m ()) + -> m () ) - -> RemoteStoreT r m () + -> m () runOpArgsIO op encoder = do sockPutS (mapErrorS RemoteStoreError_SerializerPut enum) op soc <- getStoreSocket encoder (liftIO . Network.Socket.ByteString.sendAll soc) - out <- processOutput - appendLogs out - err <- gotError - when err $ do - -- TODO: don't use show - getErrors >>= throwError . RemoteStoreError_Fixme . show + processOutput doReq - :: forall m r a + :: forall m a . ( MonadIO m - , MonadRemoteStoreR r m - , HasProtoVersion r + , MonadRemoteStore m , StoreReply a ) => StoreRequest a @@ -149,7 +118,9 @@ doReq = \case _ -> pure () - _ <- either (throwError @RemoteStoreError @m) appendLogs . fst <$> runRemoteStoreT cfg processOutput + --either (throwError @RemoteStoreError @m) (\() -> pure ()) . fst + -- <$> runRemoteStoreT cfg processOutput + processOutput --either throwError pure . fst <$> runRemoteStoreT cfg $ eres <- runRemoteStoreT cfg $ sockGetS (mapErrorS RemoteStoreError_SerializerGet (getReply @a)) @@ -268,15 +239,13 @@ runStoreSocket preStoreConfig code = $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag else pure Nothing - logs <- - mapStoreConfig - (preStoreConfigToStoreConfig minimumCommonVersion) - processOutput + mapStoreConfig + (preStoreConfigToStoreConfig minimumCommonVersion) + processOutput pure Handshake { handshakeNixVersion = daemonNixVersion , handshakeTrust = remoteTrustsUs , handshakeProtoVersion = minimumCommonVersion , handshakeRemoteProtoVersion = daemonVersion - , handshakeLogs = logs } 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 87c32ad..66e2e71 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -3,30 +3,22 @@ module System.Nix.Store.Remote.Logger ) where import Control.Monad.Except (throwError) -import Control.Monad.IO.Class (MonadIO) import Data.ByteString (ByteString) import Data.Serialize (Result(..)) -import System.Nix.StorePath (HasStoreDir(..)) 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 (RemoteStoreT, RemoteStoreError(..), clearData, getData, getProtoVersion) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, RemoteStoreError(..), appendLog, clearData, getData, getProtoVersion, setError) 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 System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) import qualified Control.Monad import qualified Data.Serialize.Get import qualified Data.Serializer processOutput - :: ( Monad m - , MonadIO m - , HasProtoVersion r - , HasStoreDir r - , HasStoreSocket r - ) - => RemoteStoreT r m [Logger] + :: MonadRemoteStore m + => m () processOutput = do protoVersion <- getProtoVersion sockGet8 >>= go . (decoder protoVersion) @@ -40,28 +32,28 @@ processOutput = do (runSerialT protoVersion $ Data.Serializer.getS logger) go - :: ( Monad m - , MonadIO m - , HasProtoVersion r - , HasStoreDir r - , HasStoreSocket r - ) + :: MonadRemoteStore m => Result (Either LoggerSError Logger) - -> RemoteStoreT r m [Logger] + -> m () go (Done ectrl leftover) = do + let loop = do + protoVersion <- getProtoVersion + sockGet8 >>= go . (decoder protoVersion) Control.Monad.unless (leftover == mempty) $ -- TODO: throwError error $ "Leftovers detected: '" ++ show leftover ++ "'" - protoVersion <- getProtoVersion case ectrl of -- TODO: tie this with throwError and better error type Left e -> error $ show e Right ctrl -> do case ctrl of - e@(Logger_Error _) -> pure [e] - Logger_Last -> pure [Logger_Last] + -- These two terminate the logger loop + e@(Logger_Error _) -> setError >> appendLog e + Logger_Last -> appendLog Logger_Last + + -- Read data from source Logger_Read _n -> do mdata <- getData case mdata of @@ -71,12 +63,21 @@ processOutput = do sockPut $ putByteString part clearData - sockGet8 >>= go . (decoder protoVersion) + loop + + -- Write data to sink + -- used with tunnel sink in ExportPath operation + Logger_Write _out -> do + -- TODO: handle me + loop + + -- Following we just append and loop + -- but listed here explicitely for posterity + x@(Logger_Next _) -> appendLog x >> loop + x@(Logger_StartActivity {}) -> appendLog x >> loop + x@(Logger_StopActivity {}) -> appendLog x >> loop + x@(Logger_Result {}) -> appendLog x >> loop - -- we should probably handle Read here as well - x -> do - next <- sockGet8 >>= go . (decoder protoVersion) - pure $ x : next go (Partial k) = do chunk <- sockGet8 go (k chunk) 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 f2856b0..5d41e1f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -16,7 +16,7 @@ module System.Nix.Store.Remote.MonadStore import Control.Monad.Except (MonadError) import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Reader (MonadReader, ask, asks) import Control.Monad.State.Strict (get, modify) import Control.Monad.Trans (MonadTrans, lift) import Control.Monad.Trans.State.Strict (StateT, runStateT, mapStateT) @@ -28,12 +28,13 @@ import Network.Socket (Socket) import System.Nix.Nar (NarSource) import System.Nix.StorePath (HasStoreDir(..), StoreDir) import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, SError) -import System.Nix.Store.Remote.Types.Logger (Logger, isError) +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(..), StoreConfig) data RemoteStoreState = RemoteStoreState { remoteStoreState_logs :: [Logger] + , remoteStoreState_gotError :: Bool , remoteStoreState_mData :: Maybe ByteString , remoteStoreState_mNarSource :: Maybe (NarSource IO) } @@ -50,6 +51,7 @@ data RemoteStoreError | RemoteStoreError_SerializerPut SError | RemoteStoreError_NoDataProvided | RemoteStoreError_NoNarSourceProvided + | RemoteStoreError_OperationFailed | RemoteStoreError_ProtocolMismatch | RemoteStoreError_RapairNotSupportedByRemoteStore -- "repairing is not supported when building through the Nix daemon" | RemoteStoreError_WorkerMagic2Mismatch @@ -113,6 +115,7 @@ runRemoteStoreT r = where emptyState = RemoteStoreState { remoteStoreState_logs = mempty + , remoteStoreState_gotError = False , remoteStoreState_mData = Nothing , remoteStoreState_mNarSource = Nothing } @@ -136,15 +139,33 @@ class ( MonadIO m ) => MonadRemoteStoreR r m where - appendLogs :: [Logger] -> m () - default appendLogs + appendLog :: Logger -> m () + default appendLog :: ( MonadTrans t , MonadRemoteStoreR r m' , m ~ t m' ) - => [Logger] + => Logger -> m () - appendLogs = lift . appendLogs + appendLog = lift . appendLog + + setError :: m () + default setError + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => m () + setError = lift setError + + clearError :: m () + default clearError + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => m () + clearError = lift clearError gotError :: m Bool default gotError @@ -155,33 +176,6 @@ class ( MonadIO m => m Bool gotError = lift gotError - getErrors :: m [Logger] - default getErrors - :: ( MonadTrans t - , MonadRemoteStoreR r m' - , m ~ t m' - ) - => m [Logger] - getErrors = lift getErrors - - getLogs :: m [Logger] - default getLogs - :: ( MonadTrans t - , MonadRemoteStoreR r m' - , m ~ t m' - ) - => m [Logger] - getLogs = lift getLogs - - flushLogs :: m () - default flushLogs - :: ( MonadTrans t - , MonadRemoteStoreR r m' - , m ~ t m' - ) - => m () - flushLogs = lift flushLogs - setData :: ByteString -> m () default setData :: ( MonadTrans t @@ -262,17 +256,14 @@ instance ( MonadIO m getStoreDir = hasStoreDir <$> RemoteStoreT ask getStoreSocket = hasStoreSocket <$> RemoteStoreT ask - appendLogs x = + appendLog x = RemoteStoreT $ modify - $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s <> x } - getLogs = remoteStoreState_logs <$> RemoteStoreT get - flushLogs = - RemoteStoreT - $ modify - $ \s -> s { remoteStoreState_logs = mempty } - gotError = any isError <$> getLogs - getErrors = filter isError <$> getLogs + $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s ++ [x] } + + setError = RemoteStoreT $ modify $ \s -> s { remoteStoreState_gotError = True } + clearError = RemoteStoreT $ modify $ \s -> s { remoteStoreState_gotError = False } + gotError = remoteStoreState_gotError <$> RemoteStoreT get getData = remoteStoreState_mData <$> RemoteStoreT get setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x } @@ -286,8 +277,8 @@ instance ( MonadIO m -- | Ask for a @StoreDir@ getProtoVersion - :: ( Monad m + :: ( MonadRemoteStoreR r m , HasProtoVersion r ) - => RemoteStoreT r m ProtoVersion -getProtoVersion = hasProtoVersion <$> RemoteStoreT ask + => m ProtoVersion +getProtoVersion = asks hasProtoVersion diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs index 94ba7e6..f84707a 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs @@ -86,8 +86,6 @@ processConnection workerHelper preStoreConfig = do , handshakeProtoVersion = ourProtoVersion -- TODO: doesn't make sense for server , handshakeRemoteProtoVersion = ourProtoVersion - -- TODO: try this - , handshakeLogs = mempty } ~() <- void $ runRemoteStoreT preStoreConfig $ do 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 8e33264..d9cb494 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -8,8 +8,8 @@ import Data.HashSet (HashSet) import Data.Serialize.Get (Get, Result(..)) import Data.Serialize.Put (Put, runPut) import Network.Socket.ByteString (recv, sendAll) -import System.Nix.StorePath (HasStoreDir, StorePath) -import System.Nix.Store.Remote.MonadStore (RemoteStoreT, RemoteStoreError(..), getStoreDir) +import System.Nix.StorePath (StorePath) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, MonadRemoteStoreR, RemoteStoreError(..), getStoreDir) import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT) import System.Nix.Store.Remote.Serialize.Prim (getInt, getByteString, getByteStrings, getPath, getPathsOrFail) import System.Nix.Store.Remote.Types (HasStoreSocket(..)) @@ -34,22 +34,20 @@ genericIncremental getsome parser = do go (Fail msg _leftover) = error msg sockGet8 - :: ( Monad m - , MonadIO m + :: ( MonadRemoteStoreR r m , HasStoreSocket r ) - => RemoteStoreT r m ByteString + => m ByteString sockGet8 = do soc <- asks hasStoreSocket liftIO $ recv soc 8 sockPut - :: ( Monad m - , MonadIO m + :: ( MonadRemoteStoreR r m , HasStoreSocket r ) => Put - -> RemoteStoreT r m () + -> m () sockPut p = do soc <- asks hasStoreSocket liftIO $ sendAll soc $ runPut p @@ -99,63 +97,40 @@ sockGetS s = do -- * Obsolete getSocketIncremental - :: ( Monad m - , MonadIO m - , HasStoreSocket r - ) + :: MonadRemoteStore m => Get a - -> RemoteStoreT r m a + -> m a getSocketIncremental = genericIncremental sockGet8 sockGet - :: ( Monad m - , MonadIO m - , HasStoreSocket r - ) + :: MonadRemoteStore m => Get a - -> RemoteStoreT r m a + -> m a sockGet = getSocketIncremental sockGetInt - :: ( Monad m - , MonadIO m - , HasStoreSocket r - , Integral a - ) - => RemoteStoreT r m a + :: (Integral a, MonadRemoteStore m) + => m a sockGetInt = getSocketIncremental getInt sockGetBool - :: ( Monad m - , MonadIO m - , HasStoreSocket r - ) - => RemoteStoreT r m Bool + :: MonadRemoteStore m + => m Bool sockGetBool = (== (1 :: Int)) <$> sockGetInt sockGetStr - :: ( Monad m - , MonadIO m - , HasStoreSocket r - ) - => RemoteStoreT r m ByteString + :: MonadRemoteStore m + => m ByteString sockGetStr = getSocketIncremental getByteString sockGetStrings - :: ( Monad m - , MonadIO m - , HasStoreSocket r - ) - => RemoteStoreT r m [ByteString] + :: MonadRemoteStore m + => m [ByteString] sockGetStrings = getSocketIncremental getByteStrings sockGetPath - :: ( Monad m - , MonadIO m - , HasStoreDir r - , HasStoreSocket r - ) - => RemoteStoreT r m StorePath + :: MonadRemoteStore m + => m StorePath sockGetPath = do sd <- getStoreDir pth <- getSocketIncremental (getPath sd) @@ -165,12 +140,8 @@ sockGetPath = do pth sockGetPathMay - :: ( Monad m - , MonadIO m - , HasStoreDir r - , HasStoreSocket r - ) - => RemoteStoreT r m (Maybe StorePath) + :: MonadRemoteStore m + => m (Maybe StorePath) sockGetPathMay = do sd <- getStoreDir pth <- getSocketIncremental (getPath sd) @@ -181,12 +152,8 @@ sockGetPathMay = do pth sockGetPaths - :: ( Monad m - , MonadIO m - , HasStoreDir r - , HasStoreSocket r - ) - => RemoteStoreT r m (HashSet StorePath) + :: MonadRemoteStore m + => m (HashSet StorePath) sockGetPaths = do sd <- getStoreDir getSocketIncremental (getPathsOrFail sd) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs index 644394c..81f62cd 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs @@ -4,7 +4,6 @@ module System.Nix.Store.Remote.Types.Handshake import Data.Text (Text) import GHC.Generics (Generic) -import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) import System.Nix.Store.Remote.Types.TrustedFlag (TrustedFlag) @@ -14,6 +13,5 @@ data Handshake = Handshake , handshakeTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us , handshakeProtoVersion :: ProtoVersion -- ^ Minimum protocol supported by both sides , handshakeRemoteProtoVersion :: ProtoVersion -- ^ Protocol supported by remote side - , handshakeLogs :: [Logger] -- ^ Logs produced right after greeting exchange } deriving (Eq, Generic, Ord, Show) From 5d927d3402b9095d776ab7f969feca5aacb5bcc9 Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 14:30:02 +0100 Subject: [PATCH 049/104] remote: handle logger errors properly --- .../src/System/Nix/Store/Remote/Logger.hs | 14 +++++++++----- .../src/System/Nix/Store/Remote/MonadStore.hs | 2 ++ 2 files changed, 11 insertions(+), 5 deletions(-) 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 66e2e71..badf80b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -41,12 +41,10 @@ processOutput = do sockGet8 >>= go . (decoder protoVersion) Control.Monad.unless (leftover == mempty) $ - -- TODO: throwError - error $ "Leftovers detected: '" ++ show leftover ++ "'" + throwError $ RemoteStoreError_LoggerLeftovers leftover case ectrl of - -- TODO: tie this with throwError and better error type - Left e -> error $ show e + Left e -> throwError $ RemoteStoreError_SerializerLogger e Right ctrl -> do case ctrl of -- These two terminate the logger loop @@ -60,6 +58,8 @@ processOutput = do Nothing -> throwError RemoteStoreError_NoDataProvided Just part -> do -- XXX: we should check/assert part size against n of (Read n) + -- ^ not really, this is just an indicator how big of a chunk + -- to read from the source sockPut $ putByteString part clearData @@ -82,4 +82,8 @@ processOutput = do chunk <- sockGet8 go (k chunk) - go (Fail msg _leftover) = error msg + go (Fail msg leftover) = + throwError + $ RemoteStoreError_LoggerParserFail + msg + leftover 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 5d41e1f..4366cff 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -49,6 +49,8 @@ data RemoteStoreError | RemoteStoreError_SerializerHandshake HandshakeSError | RemoteStoreError_SerializerLogger LoggerSError | RemoteStoreError_SerializerPut SError + | RemoteStoreError_LoggerLeftovers ByteString -- when there are bytes left over after incremental logger parser is done + | RemoteStoreError_LoggerParserFail String ByteString -- when incremental parser returns ((Fail msg leftover) :: Result) | RemoteStoreError_NoDataProvided | RemoteStoreError_NoNarSourceProvided | RemoteStoreError_OperationFailed From c4315f18422255d6db6100457da643f829bde103 Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 14:51:58 +0100 Subject: [PATCH 050/104] remote: handle IOExceptions in sockGet8 --- .../src/System/Nix/Store/Remote/MonadStore.hs | 4 ++- .../src/System/Nix/Store/Remote/Socket.hs | 26 +++++++++++-------- 2 files changed, 18 insertions(+), 12 deletions(-) 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 4366cff..70f5a30 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -14,6 +14,7 @@ module System.Nix.Store.Remote.MonadStore , getProtoVersion ) where +import Control.Exception (SomeException) import Control.Monad.Except (MonadError) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (MonadReader, ask, asks) @@ -49,6 +50,7 @@ data RemoteStoreError | RemoteStoreError_SerializerHandshake HandshakeSError | RemoteStoreError_SerializerLogger LoggerSError | RemoteStoreError_SerializerPut SError + | RemoteStoreError_IOException SomeException | RemoteStoreError_LoggerLeftovers ByteString -- when there are bytes left over after incremental logger parser is done | RemoteStoreError_LoggerParserFail String ByteString -- when incremental parser returns ((Fail msg leftover) :: Result) | RemoteStoreError_NoDataProvided @@ -60,7 +62,7 @@ data RemoteStoreError | RemoteStoreError_WorkerError WorkerError -- bad / redundant | RemoteStoreError_WorkerException WorkerException - deriving (Eq, Show, Ord) + deriving Show -- | fatal error in worker interaction which should disconnect client. data WorkerException 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 d9cb494..d4c308b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -14,6 +14,7 @@ import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT) import System.Nix.Store.Remote.Serialize.Prim (getInt, getByteString, getByteStrings, getPath, getPathsOrFail) import System.Nix.Store.Remote.Types (HasStoreSocket(..)) +import qualified Control.Exception import qualified Data.ByteString import qualified Data.Serializer import qualified Data.Serialize.Get @@ -34,13 +35,24 @@ genericIncremental getsome parser = do go (Fail msg _leftover) = error msg sockGet8 - :: ( MonadRemoteStoreR r m + :: ( MonadIO m + , MonadError RemoteStoreError m + , MonadReader r m , HasStoreSocket r ) => m ByteString sockGet8 = do soc <- asks hasStoreSocket - liftIO $ recv soc 8 + eresult <- liftIO $ Control.Exception.try $ recv soc 8 + case eresult of + Left e -> + throwError $ RemoteStoreError_IOException e + + Right result | Data.ByteString.length result == 0 -> + throwError RemoteStoreError_Disconnected + + Right result | otherwise -> + pure result sockPut :: ( MonadRemoteStoreR r m @@ -79,20 +91,12 @@ sockGetS -> m a sockGetS s = do r <- ask - res <- genericIncremental sockGet8' + res <- genericIncremental sockGet8 $ runSerialT r $ Data.Serializer.getS s case res of Right x -> pure x Left e -> throwError 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 From 6ebc2fcc5bde9b734c9c1df63feda59efd35a48e Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 14:58:58 +0100 Subject: [PATCH 051/104] remote: handle errors in genericIncremental --- .../src/System/Nix/Store/Remote/MonadStore.hs | 2 ++ .../src/System/Nix/Store/Remote/Socket.hs | 17 +++++++++++++++-- 2 files changed, 17 insertions(+), 2 deletions(-) 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 70f5a30..3c5e217 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -46,6 +46,8 @@ data RemoteStoreError | RemoteStoreError_ClientVersionTooOld | RemoteStoreError_Disconnected | RemoteStoreError_GetAddrInfoFailed + | RemoteStoreError_GenericIncrementalLeftovers ByteString -- when there are bytes left over after genericIncremental parser is done + | RemoteStoreError_GenericIncrementalFail String ByteString -- when genericIncremental parser returns ((Fail msg leftover) :: Result) | RemoteStoreError_SerializerGet SError | RemoteStoreError_SerializerHandshake HandshakeSError | RemoteStoreError_SerializerLogger LoggerSError 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 d4c308b..875b97a 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -20,7 +20,9 @@ import qualified Data.Serializer import qualified Data.Serialize.Get genericIncremental - :: MonadIO m + :: ( MonadIO m + , MonadError RemoteStoreError m + ) => m ByteString -> Get a -> m a @@ -28,11 +30,22 @@ genericIncremental getsome parser = do getsome >>= go . decoder where decoder = Data.Serialize.Get.runGetPartial parser + go (Done _ leftover) | leftover /= mempty = + throwError + $ RemoteStoreError_GenericIncrementalLeftovers + leftover + go (Done x _leftover) = pure x + go (Partial k) = do chunk <- getsome go (k chunk) - go (Fail msg _leftover) = error msg + + go (Fail msg leftover) = + throwError + $ RemoteStoreError_GenericIncrementalFail + msg + leftover sockGet8 :: ( MonadIO m From f1f30af6d50be6da015ee3d4a6e5ed3ff3e57711 Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 15:05:00 +0100 Subject: [PATCH 052/104] remote: also include what was parsed (via Show) in incremental parser errors --- .../src/System/Nix/Store/Remote/Client.hs | 1 + .../src/System/Nix/Store/Remote/Logger.hs | 5 ++++- .../src/System/Nix/Store/Remote/MonadStore.hs | 4 ++-- .../src/System/Nix/Store/Remote/Socket.hs | 12 ++++++++---- 4 files changed, 15 insertions(+), 7 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 4cba45e..ea06ca8 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -98,6 +98,7 @@ doReq . ( MonadIO m , MonadRemoteStore m , StoreReply a + , Show a ) => StoreRequest a -> m 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 badf80b..b92fd68 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -41,7 +41,10 @@ processOutput = do sockGet8 >>= go . (decoder protoVersion) Control.Monad.unless (leftover == mempty) $ - throwError $ RemoteStoreError_LoggerLeftovers leftover + throwError + $ RemoteStoreError_LoggerLeftovers + (show ectrl) + leftover case ectrl of Left e -> throwError $ RemoteStoreError_SerializerLogger e 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 3c5e217..045edd3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -46,14 +46,14 @@ data RemoteStoreError | RemoteStoreError_ClientVersionTooOld | RemoteStoreError_Disconnected | RemoteStoreError_GetAddrInfoFailed - | RemoteStoreError_GenericIncrementalLeftovers ByteString -- when there are bytes left over after genericIncremental parser is done + | RemoteStoreError_GenericIncrementalLeftovers String ByteString -- when there are bytes left over after genericIncremental parser is done, (Done x leftover), first param is show x | RemoteStoreError_GenericIncrementalFail String ByteString -- when genericIncremental parser returns ((Fail msg leftover) :: Result) | RemoteStoreError_SerializerGet SError | RemoteStoreError_SerializerHandshake HandshakeSError | RemoteStoreError_SerializerLogger LoggerSError | RemoteStoreError_SerializerPut SError | RemoteStoreError_IOException SomeException - | RemoteStoreError_LoggerLeftovers ByteString -- when there are bytes left over after incremental logger parser is done + | 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_NoDataProvided | RemoteStoreError_NoNarSourceProvided 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 875b97a..14eab2f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -22,6 +22,7 @@ import qualified Data.Serialize.Get genericIncremental :: ( MonadIO m , MonadError RemoteStoreError m + , Show a ) => m ByteString -> Get a @@ -30,9 +31,10 @@ genericIncremental getsome parser = do getsome >>= go . decoder where decoder = Data.Serialize.Get.runGetPartial parser - go (Done _ leftover) | leftover /= mempty = + go (Done x leftover) | leftover /= mempty = throwError $ RemoteStoreError_GenericIncrementalLeftovers + (show x) leftover go (Done x _leftover) = pure x @@ -99,6 +101,8 @@ sockGetS , MonadError e m , MonadReader r m , MonadIO m + , Show a + , Show e ) => NixSerializer r e a -> m a @@ -114,19 +118,19 @@ sockGetS s = do -- * Obsolete getSocketIncremental - :: MonadRemoteStore m + :: (MonadRemoteStore m, Show a) => Get a -> m a getSocketIncremental = genericIncremental sockGet8 sockGet - :: MonadRemoteStore m + :: (MonadRemoteStore m, Show a) => Get a -> m a sockGet = getSocketIncremental sockGetInt - :: (Integral a, MonadRemoteStore m) + :: (Integral a, MonadRemoteStore m, Show a) => m a sockGetInt = getSocketIncremental getInt From 82262a1b1d8ee7574395ddb9e6f2ef688b74caf5 Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 15:06:28 +0100 Subject: [PATCH 053/104] remote: Client, no more need for nested runRemoteStoreT --- .../src/System/Nix/Store/Remote/Client.hs | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index ea06ca8..8df46a8 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -17,7 +17,6 @@ module System.Nix.Store.Remote.Client import Control.Monad (unless, when) import Control.Monad.Except (throwError) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (ask) import Data.Serialize.Put (Put, runPut) import Data.Some (Some(Some)) @@ -104,9 +103,7 @@ doReq -> m a doReq = \case x -> do - cfg <- ask - _ <- runRemoteStoreT cfg $ - sockPutS (mapErrorS RemoteStoreError_SerializerPut storeRequest) (Some x) + sockPutS (mapErrorS RemoteStoreError_SerializerPut storeRequest) (Some x) case x of AddToStore {} -> do @@ -119,16 +116,9 @@ doReq = \case _ -> pure () - --either (throwError @RemoteStoreError @m) (\() -> pure ()) . fst - -- <$> runRemoteStoreT cfg processOutput processOutput - --either throwError pure . fst <$> runRemoteStoreT cfg $ - eres <- runRemoteStoreT cfg $ - sockGetS (mapErrorS RemoteStoreError_SerializerGet (getReply @a)) + sockGetS (mapErrorS RemoteStoreError_SerializerGet (getReply @a)) - case eres of - (Left e, _logs) -> throwError e - (Right res, _logs) -> pure res class StoreReply a where getReply From 57cc9e360934301a4f9ac9f0ff7d6d920f3d2cce Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 16:03:19 +0100 Subject: [PATCH 054/104] remote: implement Logger_Read Adds `setDataSource` which can be used to set a function to be polled when daemon asks for data using `Logger_Read`. Function should return `Nothing` when all data was read. `clearDataSource` should be used after the operation using the data source is finished. Related to #265 --- .../src/System/Nix/Store/Remote/Logger.hs | 29 +++---- .../src/System/Nix/Store/Remote/MonadStore.hs | 75 ++++++++++--------- .../System/Nix/Store/Remote/Types/Logger.hs | 2 +- 3 files changed, 58 insertions(+), 48 deletions(-) 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 b92fd68..a2d3499 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -3,18 +3,19 @@ module System.Nix.Store.Remote.Logger ) where import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import Data.Serialize (Result(..)) -import System.Nix.Store.Remote.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 (MonadRemoteStore, RemoteStoreError(..), appendLog, clearData, getData, getProtoVersion, setError) +import System.Nix.Store.Remote.Socket (sockGet8) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, RemoteStoreError(..), appendLog, getDataSource, getStoreSocket, getProtoVersion, setError) import System.Nix.Store.Remote.Types.Logger (Logger(..)) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) import qualified Control.Monad import qualified Data.Serialize.Get import qualified Data.Serializer +import qualified Network.Socket.ByteString processOutput :: MonadRemoteStore m @@ -55,16 +56,18 @@ processOutput = do Logger_Last -> appendLog Logger_Last -- Read data from source - Logger_Read _n -> do - mdata <- getData - case mdata of - Nothing -> throwError RemoteStoreError_NoDataProvided - Just part -> do - -- XXX: we should check/assert part size against n of (Read n) - -- ^ not really, this is just an indicator how big of a chunk - -- to read from the source - sockPut $ putByteString part - clearData + Logger_Read size -> do + mSource <- getDataSource + case mSource of + Nothing -> + throwError RemoteStoreError_NoDataSourceProvided + Just source -> do + mChunk <- liftIO $ source size + case mChunk of + Nothing -> throwError RemoteStoreError_DataSourceExhausted + Just chunk -> do + sock <- getStoreSocket + liftIO $ Network.Socket.ByteString.sendAll sock chunk loop 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 045edd3..75f6684 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -36,7 +36,11 @@ import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfi data RemoteStoreState = RemoteStoreState { remoteStoreState_logs :: [Logger] , remoteStoreState_gotError :: Bool - , remoteStoreState_mData :: Maybe ByteString + , remoteStoreState_mDataSource :: 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. , remoteStoreState_mNarSource :: Maybe (NarSource IO) } @@ -55,7 +59,8 @@ data RemoteStoreError | RemoteStoreError_IOException SomeException | 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_NoDataProvided + | RemoteStoreError_NoDataSourceProvided -- remoteStoreState_mDataSource is required but it is Nothing + | RemoteStoreError_DataSourceExhausted -- remoteStoreState_mDataSource returned Nothing but more data was requested | RemoteStoreError_NoNarSourceProvided | RemoteStoreError_OperationFailed | RemoteStoreError_ProtocolMismatch @@ -122,7 +127,7 @@ runRemoteStoreT r = emptyState = RemoteStoreState { remoteStoreState_logs = mempty , remoteStoreState_gotError = False - , remoteStoreState_mData = Nothing + , remoteStoreState_mDataSource = Nothing , remoteStoreState_mNarSource = Nothing } @@ -182,34 +187,6 @@ class ( MonadIO m => m Bool gotError = lift gotError - setData :: ByteString -> m () - default setData - :: ( MonadTrans t - , MonadRemoteStoreR r m' - , m ~ t m' - ) - => ByteString - -> m () - setData = lift . setData - - getData :: m (Maybe ByteString) - default getData - :: ( MonadTrans t - , MonadRemoteStoreR r m' - , m ~ t m' - ) - => m (Maybe ByteString) - getData = lift getData - - clearData :: m () - default clearData - :: ( MonadTrans t - , MonadRemoteStoreR r m' - , m ~ t m' - ) - => m () - clearData = lift clearData - getStoreDir :: m StoreDir default getStoreDir :: ( MonadTrans t @@ -247,6 +224,36 @@ class ( MonadIO m => m (Maybe (NarSource IO)) takeNarSource = lift takeNarSource + setDataSource :: (Word64 -> IO (Maybe ByteString)) -> m () + default setDataSource + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => (Word64 -> IO (Maybe ByteString)) + -> m () + setDataSource x = lift (setDataSource x) + + getDataSource :: m (Maybe (Word64 -> IO (Maybe ByteString))) + default getDataSource + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => m (Maybe (Word64 -> IO (Maybe ByteString))) + getDataSource = lift getDataSource + + clearDataSource :: m () + default clearDataSource + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => m () + clearDataSource = lift clearDataSource + + + instance MonadRemoteStoreR r m => MonadRemoteStoreR r (StateT s m) instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ReaderT r m) instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ExceptT RemoteStoreError m) @@ -271,9 +278,9 @@ instance ( MonadIO m clearError = RemoteStoreT $ modify $ \s -> s { remoteStoreState_gotError = False } gotError = remoteStoreState_gotError <$> RemoteStoreT get - getData = remoteStoreState_mData <$> RemoteStoreT get - setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x } - clearData = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = Nothing } + setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = pure x } + getDataSource = remoteStoreState_mDataSource <$> RemoteStoreT get + clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = Nothing } setNarSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mNarSource = pure x } takeNarSource = RemoteStoreT $ do diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs index 74dd991..543b94c 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs @@ -81,7 +81,7 @@ word64ToLoggerOpCode = \case data Logger = Logger_Next Text - | Logger_Read Int -- data needed from source + | Logger_Read Word64 -- data needed from source | Logger_Write ByteString -- data for sink | Logger_Last | Logger_Error (Either BasicError ErrorInfo) From 675581903e46dd80d7dbea237eefdd3e00024acb Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 16:21:32 +0100 Subject: [PATCH 055/104] remote: implement Logger_Write Adds `setDataSink` which can be used to set a function to be called when daemon sned us data using `Logger_Write`. `clearDataSink` should be used after the operation using the data sink is finished. --- .../src/System/Nix/Store/Remote/Logger.hs | 13 ++++--- .../src/System/Nix/Store/Remote/MonadStore.hs | 36 +++++++++++++++++++ 2 files changed, 45 insertions(+), 4 deletions(-) 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 a2d3499..d932432 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -8,7 +8,7 @@ import Data.ByteString (ByteString) import Data.Serialize (Result(..)) import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT) import System.Nix.Store.Remote.Socket (sockGet8) -import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, RemoteStoreError(..), appendLog, getDataSource, getStoreSocket, getProtoVersion, setError) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, RemoteStoreError(..), appendLog, getDataSource, getDataSink, getStoreSocket, getProtoVersion, setError) import System.Nix.Store.Remote.Types.Logger (Logger(..)) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) @@ -72,9 +72,14 @@ processOutput = do loop -- Write data to sink - -- used with tunnel sink in ExportPath operation - Logger_Write _out -> do - -- TODO: handle me + Logger_Write out -> do + mSink <- getDataSink + case mSink of + Nothing -> + throwError RemoteStoreError_NoDataSinkProvided + Just sink -> do + liftIO $ sink out + loop -- Following we just append and loop 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 75f6684..ef4662f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -41,6 +41,10 @@ data RemoteStoreState = RemoteStoreState { -- 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 ()) + -- ^ Sink for @Logger_Write@, called repeatedly by the daemon + -- to dump us some data. Used by @ExportPath@ operation. , remoteStoreState_mNarSource :: Maybe (NarSource IO) } @@ -61,6 +65,7 @@ data RemoteStoreError | RemoteStoreError_LoggerParserFail String ByteString -- when incremental parser returns ((Fail msg leftover) :: Result) | RemoteStoreError_NoDataSourceProvided -- remoteStoreState_mDataSource is required but it is Nothing | RemoteStoreError_DataSourceExhausted -- remoteStoreState_mDataSource returned Nothing but more data was requested + | RemoteStoreError_NoDataSinkProvided -- remoteStoreState_mDataSink is required but it is Nothing | RemoteStoreError_NoNarSourceProvided | RemoteStoreError_OperationFailed | RemoteStoreError_ProtocolMismatch @@ -128,6 +133,7 @@ runRemoteStoreT r = { remoteStoreState_logs = mempty , remoteStoreState_gotError = False , remoteStoreState_mDataSource = Nothing + , remoteStoreState_mDataSink = Nothing , remoteStoreState_mNarSource = Nothing } @@ -252,7 +258,33 @@ class ( MonadIO m => m () clearDataSource = lift clearDataSource + setDataSink :: (ByteString -> IO ()) -> m () + default setDataSink + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => (ByteString -> IO ()) + -> m () + setDataSink x = lift (setDataSink x) + getDataSink :: m (Maybe (ByteString -> IO ())) + default getDataSink + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => m (Maybe (ByteString -> IO ())) + getDataSink = lift getDataSink + + clearDataSink :: m () + default clearDataSink + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => m () + clearDataSink = lift clearDataSink instance MonadRemoteStoreR r m => MonadRemoteStoreR r (StateT s m) instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ReaderT r m) @@ -282,6 +314,10 @@ instance ( MonadIO m getDataSource = remoteStoreState_mDataSource <$> RemoteStoreT get clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = Nothing } + setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = pure x } + getDataSink = remoteStoreState_mDataSink <$> RemoteStoreT get + clearDataSink = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = Nothing } + setNarSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mNarSource = pure x } takeNarSource = RemoteStoreT $ do x <- remoteStoreState_mNarSource <$> get From b506f1a2d7bce217b446e93faa4c507e667e35af Mon Sep 17 00:00:00 2001 From: sorki Date: Sun, 3 Dec 2023 16:51:55 +0100 Subject: [PATCH 056/104] remote: use DList Logger instead of slow-to-append-to list. Thanks for the suggestion! Closes #63. Co-Authored-By: Travis Whitaker --- docs/01-Contributors.org | 3 ++- hnix-store-remote/hnix-store-remote.cabal | 1 + hnix-store-remote/src/System/Nix/Store/Remote.hs | 2 +- hnix-store-remote/src/System/Nix/Store/Remote/Client.hs | 3 ++- .../src/System/Nix/Store/Remote/MonadStore.hs | 9 ++++++--- hnix-store-remote/tests-io/NixDaemon.hs | 5 +++-- 6 files changed, 15 insertions(+), 8 deletions(-) diff --git a/docs/01-Contributors.org b/docs/01-Contributors.org index 48d86fa..c3266f1 100644 --- a/docs/01-Contributors.org +++ b/docs/01-Contributors.org @@ -28,4 +28,5 @@ in order of appearance: + Luigy Leon @luigy + squalus @squalus + Vaibhav Sagar @vaibhavsagar -* Ryan Trinkle @ryantrinkle ++ Ryan Trinkle @ryantrinkle ++ Travis Whitaker @TravisWhitaker diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index e41b03a..e07b2e0 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -117,6 +117,7 @@ library , data-default-class , dependent-sum > 0.7 , dependent-sum-template > 0.1.1 && < 0.3 + , dlist >= 1.0 , generic-arbitrary < 1.1 , hashable , text diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 0cd57e3..838f718 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -121,7 +121,7 @@ runStoreOptsTCP host port sd code = do (Network.Socket.addrAddress sockAddr) sd code - _ -> pure (Left RemoteStoreError_GetAddrInfoFailed, []) + _ -> pure (Left RemoteStoreError_GetAddrInfoFailed, mempty) runStoreOpts' :: Family diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 8df46a8..7cdb539 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -17,6 +17,7 @@ module System.Nix.Store.Remote.Client import Control.Monad (unless, when) import Control.Monad.Except (throwError) import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.DList (DList) import Data.Serialize.Put (Put, runPut) import Data.Some (Some(Some)) @@ -157,7 +158,7 @@ addToStore name source method hashAlgo repair = do isValidPath :: MonadRemoteStore m => StorePath -> m Bool isValidPath = doReq . IsValidPath -type Run m a = m (Either RemoteStoreError a, [Logger]) +type Run m a = m (Either RemoteStoreError a, DList Logger) runStoreSocket :: ( Monad m 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 ef4662f..2b51f96 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -24,6 +24,7 @@ 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.DList (DList) import Data.Word (Word64) import Network.Socket (Socket) import System.Nix.Nar (NarSource) @@ -33,8 +34,10 @@ 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(..), StoreConfig) +import qualified Data.DList + data RemoteStoreState = RemoteStoreState { - remoteStoreState_logs :: [Logger] + remoteStoreState_logs :: DList Logger , remoteStoreState_gotError :: Bool , remoteStoreState_mDataSource :: Maybe (Word64 -> IO (Maybe ByteString)) -- ^ Source for @Logger_Read@, this will be called repeatedly @@ -121,7 +124,7 @@ runRemoteStoreT ) => r -> RemoteStoreT r m a - -> m (Either RemoteStoreError a, [Logger]) + -> m (Either RemoteStoreError a, DList Logger) runRemoteStoreT r = fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreState_logs)) . (`runReaderT` r) @@ -304,7 +307,7 @@ instance ( MonadIO m appendLog x = RemoteStoreT $ modify - $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s ++ [x] } + $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s `Data.DList.snoc` x } setError = RemoteStoreT $ modify $ \s -> s { remoteStoreState_gotError = True } clearError = RemoteStoreT $ modify $ \s -> s { remoteStoreState_gotError = False } diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index 1088cc0..9762e24 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemon.hs @@ -29,6 +29,7 @@ import System.Nix.Build import System.Nix.StorePath import System.Nix.StorePath.Metadata import System.Nix.Store.Remote +import System.Nix.Store.Remote.Client (Run) import System.Nix.Store.Remote.MonadStore (mapStoreConfig) import Crypto.Hash (SHA256) @@ -89,7 +90,7 @@ error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e561612 startDaemon :: FilePath - -> IO (P.ProcessHandle, MonadStore a -> IO (Either RemoteStoreError a, [Logger])) + -> IO (P.ProcessHandle, MonadStore a -> Run IO a) startDaemon fp = do writeConf (fp "etc" "nix.conf") p <- createProcessEnv fp "nix-daemon" [] @@ -110,7 +111,7 @@ enterNamespaces = do writeGroupMappings Nothing [GroupMapping 0 gid 1] True withNixDaemon - :: ((MonadStore a -> IO (Either RemoteStoreError a, [Logger])) -> IO a) -> IO a + :: ((MonadStore a -> Run IO a) -> IO a) -> IO a withNixDaemon action = withSystemTempDirectory "test-nix-store" $ \path -> do From 2443d3859f4c90a9ccd5d9d0d021c4ce6a3be936 Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 17:16:57 +0100 Subject: [PATCH 057/104] remote: pretty doReq, add haddock --- .../src/System/Nix/Store/Remote/Client.hs | 23 +++++++++++++++---- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 7cdb539..0f2a39f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -93,6 +93,7 @@ runOpArgsIO op encoder = do processOutput +-- | Perform @StoreRequest@ doReq :: forall m a . ( MonadIO m @@ -104,7 +105,13 @@ doReq -> m a doReq = \case x -> do - sockPutS (mapErrorS RemoteStoreError_SerializerPut storeRequest) (Some x) + sockPutS + (mapErrorS + RemoteStoreError_SerializerPut + storeRequest + ) + (Some x) + case x of AddToStore {} -> do @@ -112,14 +119,20 @@ doReq = \case case ms of Just (stream :: NarSource IO) -> do soc <- getStoreSocket - liftIO $ stream $ Network.Socket.ByteString.sendAll soc - Nothing -> throwError RemoteStoreError_NoNarSourceProvided + liftIO + $ stream + $ Network.Socket.ByteString.sendAll soc + Nothing -> + throwError + RemoteStoreError_NoNarSourceProvided _ -> pure () processOutput - sockGetS (mapErrorS RemoteStoreError_SerializerGet (getReply @a)) - + sockGetS + (mapErrorS RemoteStoreError_SerializerGet + $ getReply @a + ) class StoreReply a where getReply From 218689d610931207eb5a8cc22b1cc4117bb03f62 Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 17:46:04 +0100 Subject: [PATCH 058/104] remote: add RequestSError, shave off undefineds --- .../src/System/Nix/Store/Remote/Client.hs | 2 +- .../src/System/Nix/Store/Remote/MonadStore.hs | 3 +- .../src/System/Nix/Store/Remote/Serializer.hs | 180 +++++++++++------- .../src/System/Nix/Store/Remote/Server.hs | 2 +- 4 files changed, 111 insertions(+), 76 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 0f2a39f..e1db2c9 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -107,7 +107,7 @@ doReq = \case x -> do sockPutS (mapErrorS - RemoteStoreError_SerializerPut + RemoteStoreError_SerializerRequest storeRequest ) (Some x) 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 2b51f96..2dfa1b8 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -29,7 +29,7 @@ import Data.Word (Word64) import Network.Socket (Socket) import System.Nix.Nar (NarSource) import System.Nix.StorePath (HasStoreDir(..), StoreDir) -import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, SError) +import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, SError) 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(..), StoreConfig) @@ -63,6 +63,7 @@ data RemoteStoreError | RemoteStoreError_SerializerHandshake HandshakeSError | RemoteStoreError_SerializerLogger LoggerSError | RemoteStoreError_SerializerPut SError + | RemoteStoreError_SerializerRequest RequestSError | RemoteStoreError_IOException SomeException | 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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index fe49852..e8625a6 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -72,6 +72,7 @@ module System.Nix.Store.Remote.Serializer , trustedFlag -- * Worker protocol , storeText + , RequestSError(..) , workerOp , storeRequest ) where @@ -973,6 +974,14 @@ storeText = Serializer putS text storeTextText } +data RequestSError + = RequestSError_NotYetImplemented WorkerOp + | RequestSError_ReservedOp WorkerOp + | RequestSError_PrimGet SError + | RequestSError_PrimPut SError + | RequestSError_PrimWorkerOp SError + deriving (Eq, Ord, Generic, Show) + workerOp :: NixSerializer r SError WorkerOp workerOp = enum @@ -980,10 +989,10 @@ storeRequest :: ( HasProtoVersion r , HasStoreDir r ) - => NixSerializer r SError (Some StoreRequest) + => NixSerializer r RequestSError (Some StoreRequest) storeRequest = Serializer - { getS = getS workerOp >>= \case - WorkerOp_AddToStore -> do + { getS = mapErrorST RequestSError_PrimWorkerOp (getS workerOp) >>= \case + WorkerOp_AddToStore -> mapGetE $ do pathName <- getS storePathName _fixed <- getS bool -- obsolete recursive <- getS enum @@ -994,35 +1003,35 @@ storeRequest = Serializer pure $ Some (AddToStore pathName recursive hashAlgo repair) - WorkerOp_AddTextToStore -> do + WorkerOp_AddTextToStore -> mapGetE $ do txt <- getS storeText paths <- getS (hashSet storePath) let repair = RepairMode_DontRepair pure $ Some (AddTextToStore txt paths repair) - WorkerOp_AddSignatures -> do + WorkerOp_AddSignatures -> mapGetE $ do path <- getS storePath signatures <- getS (set signature) pure $ Some (AddSignatures path signatures) - WorkerOp_AddIndirectRoot -> + WorkerOp_AddIndirectRoot -> mapGetE $ do Some . AddIndirectRoot <$> getS storePath - WorkerOp_AddTempRoot -> + WorkerOp_AddTempRoot -> mapGetE $ do Some . AddTempRoot <$> getS storePath - WorkerOp_BuildPaths -> do + WorkerOp_BuildPaths -> mapGetE $ do derived <- getS (set derivedPath) buildMode' <- getS buildMode pure $ Some (BuildPaths derived buildMode') - WorkerOp_BuildDerivation -> do + WorkerOp_BuildDerivation -> mapGetE $ do path <- getS storePath drv <- getS derivation buildMode' <- getS buildMode pure $ Some (BuildDerivation path drv buildMode') - WorkerOp_CollectGarbage -> do + WorkerOp_CollectGarbage -> mapGetE $ do gcOptions_operation <- getS enum gcOptions_pathsToDelete <- getS (hashSet storePath) gcOptions_ignoreLiveness <- getS bool @@ -1032,86 +1041,86 @@ storeRequest = Serializer $ pure $ getS (int @Word8) pure $ Some (CollectGarbage GCOptions{..}) - WorkerOp_EnsurePath -> + WorkerOp_EnsurePath -> mapGetE $ do Some . EnsurePath <$> getS storePath - WorkerOp_FindRoots -> do + WorkerOp_FindRoots -> mapGetE $ do pure $ Some FindRoots - WorkerOp_IsValidPath -> + WorkerOp_IsValidPath -> mapGetE $ do Some . IsValidPath <$> getS storePath - WorkerOp_QueryValidPaths -> do + WorkerOp_QueryValidPaths -> mapGetE $ do paths <- getS (hashSet storePath) substituteMode <- getS enum pure $ Some (QueryValidPaths paths substituteMode) - WorkerOp_QueryAllValidPaths -> + WorkerOp_QueryAllValidPaths -> mapGetE $ do pure $ Some QueryAllValidPaths - WorkerOp_QuerySubstitutablePaths -> + WorkerOp_QuerySubstitutablePaths -> mapGetE $ do Some . QuerySubstitutablePaths <$> getS (hashSet storePath) - WorkerOp_QueryPathInfo -> + WorkerOp_QueryPathInfo -> mapGetE $ do Some . QueryPathInfo <$> getS storePath - WorkerOp_QueryReferrers -> + WorkerOp_QueryReferrers -> mapGetE $ do Some . QueryReferrers <$> getS storePath - WorkerOp_QueryValidDerivers -> + WorkerOp_QueryValidDerivers -> mapGetE $ do Some . QueryValidDerivers <$> getS storePath - WorkerOp_QueryDerivationOutputs -> + WorkerOp_QueryDerivationOutputs -> mapGetE $ do Some . QueryDerivationOutputs <$> getS storePath - WorkerOp_QueryDerivationOutputNames -> + WorkerOp_QueryDerivationOutputNames -> mapGetE $ do Some . QueryDerivationOutputNames <$> getS storePath - WorkerOp_QueryPathFromHashPart -> + WorkerOp_QueryPathFromHashPart -> mapGetE $ do Some . QueryPathFromHashPart <$> getS storePathHashPart - WorkerOp_QueryMissing -> + WorkerOp_QueryMissing -> mapGetE $ do Some . QueryMissing <$> getS (set derivedPath) - WorkerOp_OptimiseStore -> + WorkerOp_OptimiseStore -> mapGetE $ do pure $ Some OptimiseStore - WorkerOp_SyncWithGC -> + WorkerOp_SyncWithGC -> mapGetE $ do pure $ Some SyncWithGC - WorkerOp_VerifyStore -> do + WorkerOp_VerifyStore -> mapGetE $ do checkMode <- getS enum repairMode <- getS enum pure $ Some (VerifyStore checkMode repairMode) - WorkerOp_Reserved_0__ -> undefined - WorkerOp_Reserved_2__ -> undefined - WorkerOp_Reserved_15__ -> undefined - WorkerOp_Reserved_17__ -> undefined + w@WorkerOp_Reserved_0__ -> reserved w + w@WorkerOp_Reserved_2__ -> reserved w + w@WorkerOp_Reserved_15__ -> reserved w + w@WorkerOp_Reserved_17__ -> reserved w - WorkerOp_AddBuildLog -> undefined - WorkerOp_AddMultipleToStore -> undefined - WorkerOp_AddToStoreNar -> undefined - WorkerOp_BuildPathsWithResults -> undefined - WorkerOp_ClearFailedPaths -> undefined - WorkerOp_ExportPath -> undefined - WorkerOp_HasSubstitutes -> undefined - WorkerOp_ImportPaths -> undefined - WorkerOp_NarFromPath -> undefined - WorkerOp_QueryDerivationOutputMap -> undefined - WorkerOp_QueryDeriver -> undefined - WorkerOp_QueryFailedPaths -> undefined - WorkerOp_QueryPathHash -> undefined - WorkerOp_QueryRealisation -> undefined - WorkerOp_QuerySubstitutablePathInfo -> undefined - WorkerOp_QuerySubstitutablePathInfos -> undefined - WorkerOp_QueryReferences -> undefined - WorkerOp_RegisterDrvOutput -> undefined - WorkerOp_SetOptions -> undefined + w@WorkerOp_AddBuildLog -> notYet w + w@WorkerOp_AddMultipleToStore -> notYet w + w@WorkerOp_AddToStoreNar -> notYet w + w@WorkerOp_BuildPathsWithResults -> notYet w + w@WorkerOp_ClearFailedPaths -> notYet w + w@WorkerOp_ExportPath -> notYet w + w@WorkerOp_HasSubstitutes -> notYet w + w@WorkerOp_ImportPaths -> notYet w + w@WorkerOp_NarFromPath -> notYet w + w@WorkerOp_QueryDerivationOutputMap -> notYet w + w@WorkerOp_QueryDeriver -> notYet w + w@WorkerOp_QueryFailedPaths -> notYet w + w@WorkerOp_QueryPathHash -> notYet w + w@WorkerOp_QueryRealisation -> notYet w + w@WorkerOp_QuerySubstitutablePathInfo -> notYet w + w@WorkerOp_QuerySubstitutablePathInfos -> notYet w + w@WorkerOp_QueryReferences -> notYet w + w@WorkerOp_RegisterDrvOutput -> notYet w + w@WorkerOp_SetOptions -> notYet w , putS = \case - Some (AddToStore pathName recursive hashAlgo _repair) -> do + Some (AddToStore pathName recursive hashAlgo _repair) -> mapPutE $ do putS workerOp WorkerOp_AddToStore putS storePathName pathName @@ -1124,40 +1133,40 @@ storeRequest = Serializer putS bool (recursive == FileIngestionMethod_FileRecursive) putS someHashAlgo hashAlgo - Some (AddTextToStore txt paths _repair) -> do + Some (AddTextToStore txt paths _repair) -> mapPutE $ do putS workerOp WorkerOp_AddTextToStore putS storeText txt putS (hashSet storePath) paths - Some (AddSignatures path signatures) -> do + Some (AddSignatures path signatures) -> mapPutE $ do putS workerOp WorkerOp_AddSignatures putS storePath path putS (set signature) signatures - Some (AddIndirectRoot path) -> do + Some (AddIndirectRoot path) -> mapPutE $ do putS workerOp WorkerOp_AddIndirectRoot putS storePath path - Some (AddTempRoot path) -> do + Some (AddTempRoot path) -> mapPutE $ do putS workerOp WorkerOp_AddTempRoot putS storePath path - Some (BuildPaths derived buildMode') -> do + Some (BuildPaths derived buildMode') -> mapPutE $ do putS workerOp WorkerOp_BuildPaths putS (set derivedPath) derived putS buildMode buildMode' - Some (BuildDerivation path drv buildMode') -> do + Some (BuildDerivation path drv buildMode') -> mapPutE $ do putS workerOp WorkerOp_BuildDerivation putS storePath path putS derivation drv putS buildMode buildMode' - Some (CollectGarbage GCOptions{..}) -> do + Some (CollectGarbage GCOptions{..}) -> mapPutE $ do putS workerOp WorkerOp_CollectGarbage putS enum gcOptions_operation @@ -1168,66 +1177,91 @@ storeRequest = Serializer Control.Monad.forM_ [0..(2 :: Word8)] $ pure $ putS int (0 :: Word8) - Some (EnsurePath path) -> do + Some (EnsurePath path) -> mapPutE $ do putS workerOp WorkerOp_EnsurePath putS storePath path - Some FindRoots -> + Some FindRoots -> mapPutE $ do putS workerOp WorkerOp_FindRoots - Some (IsValidPath path) -> do + Some (IsValidPath path) -> mapPutE $ do putS workerOp WorkerOp_IsValidPath putS storePath path - Some (QueryValidPaths paths substituteMode) -> do + Some (QueryValidPaths paths substituteMode) -> mapPutE $ do putS workerOp WorkerOp_QueryValidPaths putS (hashSet storePath) paths putS enum substituteMode - Some QueryAllValidPaths -> + Some QueryAllValidPaths -> mapPutE $ do putS workerOp WorkerOp_QueryAllValidPaths - Some (QuerySubstitutablePaths paths) -> do + Some (QuerySubstitutablePaths paths) -> mapPutE $ do putS workerOp WorkerOp_QuerySubstitutablePaths putS (hashSet storePath) paths - Some (QueryPathInfo path) -> do + Some (QueryPathInfo path) -> mapPutE $ do putS workerOp WorkerOp_QueryPathInfo putS storePath path - Some (QueryReferrers path) -> do + Some (QueryReferrers path) -> mapPutE $ do putS workerOp WorkerOp_QueryReferrers putS storePath path - Some (QueryValidDerivers path) -> do + Some (QueryValidDerivers path) -> mapPutE $ do putS workerOp WorkerOp_QueryValidDerivers putS storePath path - Some (QueryDerivationOutputs path) -> do + Some (QueryDerivationOutputs path) -> mapPutE $ do putS workerOp WorkerOp_QueryDerivationOutputs putS storePath path - Some (QueryDerivationOutputNames path) -> do + Some (QueryDerivationOutputNames path) -> mapPutE $ do putS workerOp WorkerOp_QueryDerivationOutputNames putS storePath path - Some (QueryPathFromHashPart pathHashPart) -> do + Some (QueryPathFromHashPart pathHashPart) -> mapPutE $ do putS workerOp WorkerOp_QueryPathFromHashPart putS storePathHashPart pathHashPart - Some (QueryMissing derived) -> do + Some (QueryMissing derived) -> mapPutE $ do putS workerOp WorkerOp_QueryMissing putS (set derivedPath) derived - Some OptimiseStore -> + Some OptimiseStore -> mapPutE $ do putS workerOp WorkerOp_OptimiseStore - Some SyncWithGC -> + Some SyncWithGC -> mapPutE $ do putS workerOp WorkerOp_SyncWithGC - Some (VerifyStore checkMode repairMode) -> do + Some (VerifyStore checkMode repairMode) -> mapPutE $ do putS workerOp WorkerOp_VerifyStore putS enum checkMode putS enum repairMode } + where + mapGetE + :: Functor m + => SerialT r SError m a + -> SerialT r RequestSError m a + mapGetE = mapErrorST RequestSError_PrimGet + + mapPutE + :: Functor m + => SerialT r SError m a + -> SerialT r RequestSError m a + mapPutE = mapErrorST RequestSError_PrimPut + + notYet + :: MonadError RequestSError m + => WorkerOp + -> m a + notYet = throwError . RequestSError_NotYetImplemented + + reserved + :: MonadError RequestSError m + => WorkerOp + -> m a + reserved = throwError . RequestSError_ReservedOp + diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs index f84707a..462be1f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs @@ -110,7 +110,7 @@ processConnection workerHelper preStoreConfig = do someReq <- sockGetS $ mapErrorS - RemoteStoreError_SerializerGet + RemoteStoreError_SerializerRequest storeRequest lift $ performOp' workerHelper tunnelLogger someReq From de15745a642f09ec5e846b27efdb29e5bb26eee0 Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 18:30:38 +0100 Subject: [PATCH 059/104] remote: add ReplySError, RemoteStoreError_SerializerReply --- .../src/System/Nix/Store/Remote/Client.hs | 13 +++++++++---- .../src/System/Nix/Store/Remote/MonadStore.hs | 3 ++- .../src/System/Nix/Store/Remote/Serializer.hs | 18 ++++++++++++++---- 3 files changed, 25 insertions(+), 9 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index e1db2c9..26c1eeb 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -130,7 +130,7 @@ doReq = \case processOutput sockGetS - (mapErrorS RemoteStoreError_SerializerGet + (mapErrorS RemoteStoreError_SerializerReply $ getReply @a ) @@ -139,13 +139,18 @@ class StoreReply a where :: ( HasStoreDir r , HasProtoVersion r ) - => NixSerializer r SError a + => NixSerializer r ReplySError a instance StoreReply Bool where - getReply = bool + getReply = mapPrimE bool instance StoreReply StorePath where - getReply = storePath + getReply = mapPrimE storePath + +mapPrimE + :: NixSerializer r SError a + -> NixSerializer r ReplySError a +mapPrimE = mapErrorS ReplySError_Prim -- | Add `NarSource` to the store addToStore 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 2dfa1b8..edd9cd6 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -29,7 +29,7 @@ import Data.Word (Word64) import Network.Socket (Socket) import System.Nix.Nar (NarSource) import System.Nix.StorePath (HasStoreDir(..), StoreDir) -import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, SError) +import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, ReplySError, SError) 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(..), StoreConfig) @@ -64,6 +64,7 @@ data RemoteStoreError | RemoteStoreError_SerializerLogger LoggerSError | RemoteStoreError_SerializerPut SError | RemoteStoreError_SerializerRequest RequestSError + | RemoteStoreError_SerializerReply ReplySError | RemoteStoreError_IOException SomeException | 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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index e8625a6..064bd45 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -72,9 +72,12 @@ module System.Nix.Store.Remote.Serializer , trustedFlag -- * Worker protocol , storeText - , RequestSError(..) , workerOp + -- ** Request + , RequestSError(..) , storeRequest + -- ** Reply + , ReplySError(..) ) where import Control.Monad.Except (MonadError, throwError, ) @@ -974,6 +977,11 @@ storeText = Serializer putS text storeTextText } +workerOp :: NixSerializer r SError WorkerOp +workerOp = enum + +-- * Request + data RequestSError = RequestSError_NotYetImplemented WorkerOp | RequestSError_ReservedOp WorkerOp @@ -982,9 +990,6 @@ data RequestSError | RequestSError_PrimWorkerOp SError deriving (Eq, Ord, Generic, Show) -workerOp :: NixSerializer r SError WorkerOp -workerOp = enum - storeRequest :: ( HasProtoVersion r , HasStoreDir r @@ -1265,3 +1270,8 @@ storeRequest = Serializer -> m a reserved = throwError . RequestSError_ReservedOp +-- * Reply + +data ReplySError + = ReplySError_Prim SError + deriving (Eq, Ord, Generic, Show) From 497d0f6d053934b7053eaf6db00423f0b608ae33 Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 18:36:43 +0100 Subject: [PATCH 060/104] remote: move StoreReply to Types.StoreReply --- hnix-store-remote/hnix-store-remote.cabal | 1 + .../src/System/Nix/Store/Remote/Client.hs | 33 ++++--------------- .../Nix/Store/Remote/Types/StoreReply.hs | 30 +++++++++++++++++ 3 files changed, 37 insertions(+), 27 deletions(-) create mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index e07b2e0..1bc5070 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -96,6 +96,7 @@ library , System.Nix.Store.Remote.Types.Query.Missing , System.Nix.Store.Remote.Types.StoreConfig , System.Nix.Store.Remote.Types.StoreRequest + , System.Nix.Store.Remote.Types.StoreReply , System.Nix.Store.Remote.Types.StoreText , System.Nix.Store.Remote.Types.SubstituteMode , System.Nix.Store.Remote.Types.TrustedFlag diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 26c1eeb..935eb5e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -24,24 +24,21 @@ import Data.Some (Some(Some)) import qualified Data.ByteString import qualified Network.Socket.ByteString +import System.Nix.Hash (HashAlgo(..)) import System.Nix.Nar (NarSource) -import System.Nix.StorePath (HasStoreDir(..), StorePath) +import System.Nix.StorePath (StorePath, StorePathName) import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) ---import System.Nix.Store.Remote.Serializer (NixSerializer, SError, bool, enum, int, mapErrorS, protoVersion, storeRequest, text, trustedFlag, workerMagic) -import System.Nix.Store.Remote.Serializer +import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, storeRequest, text, trustedFlag, workerMagic) import System.Nix.Store.Remote.Types.Handshake (Handshake(..)) import System.Nix.Store.Remote.Types.Logger (Logger) -import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion, ProtoVersion(..), ourProtoVersion) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) +import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..)) import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) - --- WIP ops -import System.Nix.Hash (HashAlgo(..)) -import System.Nix.StorePath (StorePathName) import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) simpleOp @@ -131,27 +128,9 @@ doReq = \case processOutput sockGetS (mapErrorS RemoteStoreError_SerializerReply - $ getReply @a + $ getReplyS @a ) -class StoreReply a where - getReply - :: ( HasStoreDir r - , HasProtoVersion r - ) - => NixSerializer r ReplySError a - -instance StoreReply Bool where - getReply = mapPrimE bool - -instance StoreReply StorePath where - getReply = mapPrimE storePath - -mapPrimE - :: NixSerializer r SError a - -> NixSerializer r ReplySError a -mapPrimE = mapErrorS ReplySError_Prim - -- | Add `NarSource` to the store addToStore :: MonadRemoteStore m diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs new file mode 100644 index 0000000..33cbe6c --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -0,0 +1,30 @@ +module System.Nix.Store.Remote.Types.StoreReply + ( StoreReply(..) + ) where + +import System.Nix.StorePath (HasStoreDir(..), StorePath) +import System.Nix.Store.Remote.Serializer +import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion) + +-- | Get @NixSerializer@ for some type @a@ +-- This could also be generalized for every type +-- we have a serializer for but we mostly need +-- this for replies and it would make look serializers +-- quite hodor, like @a <- getS get; b <- getS get@ +class StoreReply a where + getReplyS + :: ( HasStoreDir r + , HasProtoVersion r + ) + => NixSerializer r ReplySError a + +instance StoreReply Bool where + getReplyS = mapPrimE bool + +instance StoreReply StorePath where + getReplyS = mapPrimE storePath + +mapPrimE + :: NixSerializer r SError a + -> NixSerializer r ReplySError a +mapPrimE = mapErrorS ReplySError_Prim From d3c9bc3bf1497ae9224b050c49849b47c2aec297 Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 18:51:07 +0100 Subject: [PATCH 061/104] remote: fix buildResult whitespace --- .../src/System/Nix/Store/Remote/Serializer.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 064bd45..1feb31e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -712,13 +712,13 @@ buildResult = Serializer stopTime <- getS time pure $ BuildResult{..} - , putS = \BuildResult{..} -> do - putS enum status - putS maybeText errorMessage - putS int timesBuilt - putS bool isNonDeterministic - putS time startTime - putS time stopTime + , putS = \BuildResult{..} -> do + putS enum status + putS maybeText errorMessage + putS int timesBuilt + putS bool isNonDeterministic + putS time startTime + putS time stopTime } -- * Logger From fb1bcfdb617929ed57b9b0aa123d205eb2bd1376 Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 18:57:07 +0100 Subject: [PATCH 062/104] prefix BuildResult fields --- hnix-store-core/src/System/Nix/Build.hs | 14 +++++------ .../src/System/Nix/Store/Remote/Serialize.hs | 24 +++++++++---------- .../src/System/Nix/Store/Remote/Serializer.hs | 24 +++++++++---------- .../src/System/Nix/Arbitrary/Build.hs | 12 +++++----- 4 files changed, 37 insertions(+), 37 deletions(-) diff --git a/hnix-store-core/src/System/Nix/Build.hs b/hnix-store-core/src/System/Nix/Build.hs index abd6af3..b28de93 100644 --- a/hnix-store-core/src/System/Nix/Build.hs +++ b/hnix-store-core/src/System/Nix/Build.hs @@ -42,23 +42,23 @@ data BuildStatus = -- | Result of the build data BuildResult = BuildResult { -- | build status, MiscFailure should be default - status :: !BuildStatus + buildResultStatus :: !BuildStatus , -- | possible build error message - errorMessage :: !(Maybe Text) + buildResultErrorMessage :: !(Maybe Text) , -- | How many times this build was performed - timesBuilt :: !Int + buildResultTimesBuilt :: !Int , -- | If timesBuilt > 1, whether some builds did not produce the same result - isNonDeterministic :: !Bool + buildResultIsNonDeterministic :: !Bool , -- Start time of this build - startTime :: !UTCTime + buildResultStartTime :: !UTCTime , -- Stop time of this build - stopTime :: !UTCTime + buildResultStopTime :: !UTCTime } deriving (Eq, Generic, Ord, Show) buildSuccess :: BuildResult -> Bool buildSuccess BuildResult {..} = - status `elem` + buildResultStatus `elem` [ BuildStatus_Built , BuildStatus_Substituted , BuildStatus_AlreadyValid diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs index 20fafd7..2ac6d56 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs @@ -41,25 +41,25 @@ instance Serialize BuildStatus where instance Serialize BuildResult where get = do - status <- get - errorMessage <- + buildResultStatus <- get + buildResultErrorMessage <- (\em -> Data.Bool.bool (Just em) Nothing (Data.Text.null em)) <$> get - timesBuilt <- getInt - isNonDeterministic <- getBool - startTime <- getTime - stopTime <- getTime + buildResultTimesBuilt <- getInt + buildResultIsNonDeterministic <- getBool + buildResultStartTime <- getTime + buildResultStopTime <- getTime pure $ BuildResult{..} put BuildResult{..} = do - put status - case errorMessage of + put buildResultStatus + case buildResultErrorMessage of Just err -> putText err Nothing -> putText mempty - putInt timesBuilt - putBool isNonDeterministic - putTime startTime - putTime stopTime + putInt buildResultTimesBuilt + putBool buildResultIsNonDeterministic + putTime buildResultStartTime + putTime buildResultStopTime -- * GCAction -- diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 1feb31e..6f72eca 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -704,21 +704,21 @@ buildMode = enum buildResult :: NixSerializer r SError BuildResult buildResult = Serializer { getS = do - status <- getS enum - errorMessage <- getS maybeText - timesBuilt <- getS int - isNonDeterministic <- getS bool - startTime <- getS time - stopTime <- getS time + buildResultStatus <- getS enum + buildResultErrorMessage <- getS maybeText + buildResultTimesBuilt <- getS int + buildResultIsNonDeterministic <- getS bool + buildResultStartTime <- getS time + buildResultStopTime <- getS time pure $ BuildResult{..} , putS = \BuildResult{..} -> do - putS enum status - putS maybeText errorMessage - putS int timesBuilt - putS bool isNonDeterministic - putS time startTime - putS time stopTime + putS enum buildResultStatus + putS maybeText buildResultErrorMessage + putS int buildResultTimesBuilt + putS bool buildResultIsNonDeterministic + putS time buildResultStartTime + putS time buildResultStopTime } -- * Logger diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs index 3ab100d..1ff672c 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs @@ -18,12 +18,12 @@ deriving via GenericArbitrary BuildStatus instance Arbitrary BuildResult where arbitrary = do - status <- arbitrary + buildResultStatus <- arbitrary -- we encode empty errorMessage as Nothing - errorMessage <- arbitrary `suchThat` (/= Just mempty) - timesBuilt <- arbitrary - isNonDeterministic <- arbitrary - startTime <- arbitrary - stopTime <- arbitrary + buildResultErrorMessage <- arbitrary `suchThat` (/= Just mempty) + buildResultTimesBuilt <- arbitrary + buildResultIsNonDeterministic <- arbitrary + buildResultStartTime <- arbitrary + buildResultStopTime <- arbitrary pure $ BuildResult{..} From a8077c5031b37b4806dc86100cee7c5bd1461e19 Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 19:04:32 +0100 Subject: [PATCH 063/104] prefix Metadata fields --- hnix-store-core/src/System/Nix/Fingerprint.hs | 9 ++++-- .../src/System/Nix/StorePath/Metadata.hs | 16 +++++----- hnix-store-core/tests/Fingerprint.hs | 22 +++++++------ .../src/System/Nix/Store/Remote.hs | 16 +++++----- .../src/System/Nix/Store/Remote/Serializer.hs | 32 +++++++++---------- hnix-store-remote/tests-io/NixDaemon.hs | 2 +- hnix-store-remote/tests/NixSerializerSpec.hs | 4 +-- 7 files changed, 55 insertions(+), 46 deletions(-) diff --git a/hnix-store-core/src/System/Nix/Fingerprint.hs b/hnix-store-core/src/System/Nix/Fingerprint.hs index 3416719..4eb7f30 100644 --- a/hnix-store-core/src/System/Nix/Fingerprint.hs +++ b/hnix-store-core/src/System/Nix/Fingerprint.hs @@ -26,8 +26,13 @@ import qualified Data.Text as Text -- | Produce the message signed by a NAR signature metadataFingerprint :: StoreDir -> StorePath -> Metadata StorePath -> Text metadataFingerprint storeDir storePath Metadata{..} = let - narSize = fromMaybe 0 narBytes - in fingerprint storeDir storePath narHash narSize (HashSet.toList references) + narSize = fromMaybe 0 metadataNarBytes + in fingerprint + storeDir + storePath + metadataNarHash + narSize + (HashSet.toList metadataReferences) -- | Produce the message signed by a NAR signature fingerprint :: StoreDir diff --git a/hnix-store-core/src/System/Nix/StorePath/Metadata.hs b/hnix-store-core/src/System/Nix/StorePath/Metadata.hs index 795bcc6..552ca68 100644 --- a/hnix-store-core/src/System/Nix/StorePath/Metadata.hs +++ b/hnix-store-core/src/System/Nix/StorePath/Metadata.hs @@ -35,25 +35,25 @@ data StorePathTrust data Metadata a = Metadata { -- | The path to the derivation file that built this path, if any -- and known. - deriverPath :: !(Maybe a) + metadataDeriverPath :: !(Maybe a) , -- | The hash of the nar serialization of the path. - narHash :: !(DSum HashAlgo Digest) + metadataNarHash :: !(DSum HashAlgo Digest) , -- | The paths that this path directly references - references :: !(HashSet a) + metadataReferences :: !(HashSet a) , -- | When was this path registered valid in the store? - registrationTime :: !UTCTime + metadataRegistrationTime :: !UTCTime , -- | The size of the nar serialization of the path, in bytes. - narBytes :: !(Maybe Word64) + metadataNarBytes :: !(Maybe Word64) , -- | How much we trust this path. Nix-es ultimate - trust :: !StorePathTrust + metadataTrust :: !StorePathTrust , -- | A set of cryptographic attestations of this path's validity. -- -- There is no guarantee from this type alone that these -- signatures are valid. - sigs :: !(Set NarSignature) + metadataSigs :: !(Set NarSignature) , -- | Whether and how this store path is content-addressable. -- -- There is no guarantee from this type alone that this address -- is actually correct for this store path. - contentAddress :: !(Maybe ContentAddress) + metadataContentAddress :: !(Maybe ContentAddress) } deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-core/tests/Fingerprint.hs b/hnix-store-core/tests/Fingerprint.hs index 68e4926..8874ffc 100644 --- a/hnix-store-core/tests/Fingerprint.hs +++ b/hnix-store-core/tests/Fingerprint.hs @@ -31,7 +31,11 @@ spec_fingerprint = do it "allows a successful signature verification" $ do let msg = Text.encodeUtf8 $ metadataFingerprint def exampleStorePath exampleMetadata - Signature sig' = head $ sig <$> filter (\(NarSignature publicKey _) -> publicKey == "cache.nixos.org-1") (Set.toList (sigs exampleMetadata)) + Signature sig' = + head + $ sig + <$> filter (\(NarSignature publicKey _) -> publicKey == "cache.nixos.org-1") + (Set.toList (metadataSigs exampleMetadata)) sig' `shouldSatisfy` Ed25519.verify pubkey msg exampleFingerprint :: Text @@ -42,14 +46,14 @@ exampleStorePath = forceRight $ parsePath def "/nix/store/syd87l2rxw8cbsxmxl853h exampleMetadata :: Metadata StorePath exampleMetadata = Metadata - { deriverPath = Just $ forceRight $ parsePath def "/nix/store/5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv" - , narHash = forceRight $ mkNamedDigest "sha256" "1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0" - , references = HashSet.fromList $ forceRight . parsePath def <$> ["/nix/store/0jqd0rlxzra1rs38rdxl43yh6rxchgc6-curl-7.82.0","/nix/store/6w8g7njm4mck5dmjxws0z1xnrxvl81xa-glibc-2.34-115","/nix/store/j5jxw3iy7bbz4a57fh9g2xm2gxmyal8h-zlib-1.2.12","/nix/store/yxvjs9drzsphm9pcf42a4byzj1kb9m7k-openssl-1.1.1n"] - , registrationTime = UTCTime (fromOrdinalDate 0 0) 0 - , narBytes = Just 196040 - , trust = BuiltElsewhere - , sigs = Set.fromList $ forceRight . parseNarSignature <$> ["cache.nixos.org-1:TsTTb3WGTZKphvYdBHXwo6weVILmTytUjLB+vcX89fOjjRicCHmKA4RCPMVLkj6TMJ4GMX3HPVWRdD1hkeKZBQ==", "test1:519iiVLx/c4Rdt5DNt6Y2Jm6hcWE9+XY69ygiWSZCNGVcmOcyL64uVAJ3cV8vaTusIZdbTnYo9Y7vDNeTmmMBQ=="] - , contentAddress = Nothing + { metadataDeriverPath = Just $ forceRight $ parsePath def "/nix/store/5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv" + , metadataNarHash = forceRight $ mkNamedDigest "sha256" "1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0" + , metadataReferences = HashSet.fromList $ forceRight . parsePath def <$> ["/nix/store/0jqd0rlxzra1rs38rdxl43yh6rxchgc6-curl-7.82.0","/nix/store/6w8g7njm4mck5dmjxws0z1xnrxvl81xa-glibc-2.34-115","/nix/store/j5jxw3iy7bbz4a57fh9g2xm2gxmyal8h-zlib-1.2.12","/nix/store/yxvjs9drzsphm9pcf42a4byzj1kb9m7k-openssl-1.1.1n"] + , metadataRegistrationTime = UTCTime (fromOrdinalDate 0 0) 0 + , metadataNarBytes = Just 196040 + , metadataTrust = BuiltElsewhere + , metadataSigs = Set.fromList $ forceRight . parseNarSignature <$> ["cache.nixos.org-1:TsTTb3WGTZKphvYdBHXwo6weVILmTytUjLB+vcX89fOjjRicCHmKA4RCPMVLkj6TMJ4GMX3HPVWRdD1hkeKZBQ==", "test1:519iiVLx/c4Rdt5DNt6Y2Jm6hcWE9+XY69ygiWSZCNGVcmOcyL64uVAJ3cV8vaTusIZdbTnYo9Y7vDNeTmmMBQ=="] + , metadataContentAddress = Nothing } pubkey :: Ed25519.PublicKey diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 838f718..1685d7b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -328,34 +328,34 @@ queryPathInfoUncached path = do valid <- sockGetBool Control.Monad.unless valid $ error "Path is not valid" - deriverPath <- sockGetPathMay + metadataDeriverPath <- sockGetPathMay narHashText <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr let - narHash = + metadataNarHash = case decodeDigestWith @SHA256 Base16 narHashText of Left e -> error e Right d -> System.Nix.Hash.HashAlgo_SHA256 :=> d - references <- sockGetPaths - registrationTime <- sockGet getTime - narBytes <- Just <$> sockGetInt + metadataReferences <- sockGetPaths + metadataRegistrationTime <- sockGet getTime + metadataNarBytes <- Just <$> sockGetInt ultimate <- sockGetBool sigStrings <- fmap Data.Text.Encoding.decodeUtf8 <$> sockGetStrings caString <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr let - sigs = case + metadataSigs = case Data.Set.fromList <$> mapM System.Nix.Signature.parseNarSignature sigStrings of Left e -> error e Right x -> x - contentAddress = + metadataContentAddress = if Data.Text.null caString then Nothing else case Data.Attoparsec.Text.parseOnly @@ -365,7 +365,7 @@ queryPathInfoUncached path = do Left e -> error e Right x -> Just x - trust = if ultimate then BuiltLocally else BuiltElsewhere + metadataTrust = if ultimate then BuiltLocally else BuiltElsewhere pure $ Metadata{..} diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 6f72eca..c016fa4 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -501,25 +501,25 @@ pathMetadata => NixSerializer r SError (Metadata StorePath) pathMetadata = Serializer { getS = do - deriverPath <- getS maybePath + metadataDeriverPath <- getS maybePath digest' <- getS $ digest NixBase32 - let narHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest' + let metadataNarHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest' - references <- getS $ hashSet storePath - registrationTime <- getS time - narBytes <- (\case + metadataReferences <- getS $ hashSet storePath + metadataRegistrationTime <- getS time + metadataNarBytes <- (\case 0 -> Nothing size -> Just size) <$> getS int - trust <- getS storePathTrust + metadataTrust <- getS storePathTrust - sigs <- getS $ set narSignature - contentAddress <- getS maybeContentAddress + metadataSigs <- getS $ set narSignature + metadataContentAddress <- getS maybeContentAddress pure $ Metadata{..} , putS = \Metadata{..} -> do - putS maybePath deriverPath + putS maybePath metadataDeriverPath let putNarHash :: DSum HashAlgo Digest @@ -529,14 +529,14 @@ pathMetadata = Serializer -> putS (digest @SHA256 NixBase32) d _ -> throwError SError_NarHashMustBeSHA256 - putNarHash narHash + putNarHash metadataNarHash - putS (hashSet storePath) references - putS time registrationTime - putS int $ Prelude.maybe 0 id $ narBytes - putS storePathTrust trust - putS (set narSignature) sigs - putS maybeContentAddress contentAddress + putS (hashSet storePath) metadataReferences + putS time metadataRegistrationTime + putS int $ Prelude.maybe 0 id $ metadataNarBytes + putS storePathTrust metadataTrust + putS (set narSignature) metadataSigs + putS maybeContentAddress metadataContentAddress } where maybeContentAddress diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index 9762e24..4c4e857 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemon.hs @@ -227,7 +227,7 @@ spec_protocol = Hspec.around withNixDaemon $ context "queryPathInfoUncached" $ itRights "queries path info" $ withPath $ \path -> do meta <- queryPathInfoUncached path - references meta `shouldSatisfy` HS.null + metadataReferences meta `shouldSatisfy` HS.null context "ensurePath" $ itRights "simple ensure" $ withPath ensurePath diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 09f3c4f..5bb6711 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -82,12 +82,12 @@ spec = parallel $ do roundtripS storePathName let narHashIsSHA256 Metadata{..} = - case narHash of + case metadataNarHash of (System.Nix.Hash.HashAlgo_SHA256 :=> _) -> True _ -> False prop "Metadata (StorePath)" - $ \sd -> forAll (arbitrary `suchThat` (\m -> narHashIsSHA256 m && narBytes m /= Just 0)) + $ \sd -> forAll (arbitrary `suchThat` (\m -> narHashIsSHA256 m && metadataNarBytes m /= Just 0)) $ roundtripSReader @StoreDir pathMetadata sd prop "Some HashAlgo" $ From 2cd4c32b8469520e7a09262cf3125cb1826542f1 Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 19:11:59 +0100 Subject: [PATCH 064/104] tests: custom Arbitrary Metadata instance with forced SHA256 metadataNarHash, w/o (Just0) metadataNarBytes --- hnix-store-remote/hnix-store-remote.cabal | 1 - hnix-store-remote/tests/NixSerializerSpec.hs | 14 ++----------- .../Nix/Arbitrary/StorePath/Metadata.hs | 21 ++++++++++++++----- 3 files changed, 18 insertions(+), 18 deletions(-) diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 1bc5070..ae3843b 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -178,7 +178,6 @@ test-suite remote , hnix-store-tests , cereal , crypton - , dependent-sum > 0.7 , some > 1.0.5 && < 2 , text , time diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 5bb6711..e9e913b 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -3,7 +3,6 @@ module NixSerializerSpec (spec) where import Crypto.Hash (MD5, SHA1, SHA256, SHA512) -import Data.Dependent.Sum (DSum((:=>))) import Data.Some (Some(Some)) import Data.Time (UTCTime) import Data.Word (Word64) @@ -11,12 +10,9 @@ import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, arbitrary, forAll, suchThat) -import qualified System.Nix.Hash - import System.Nix.Arbitrary () import System.Nix.Derivation (Derivation(inputDrvs)) import System.Nix.StorePath (StoreDir) -import System.Nix.StorePath.Metadata (Metadata(..)) import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.Logger (Logger(..)) @@ -81,14 +77,8 @@ spec = parallel $ do prop "StorePathName" $ roundtripS storePathName - let narHashIsSHA256 Metadata{..} = - case metadataNarHash of - (System.Nix.Hash.HashAlgo_SHA256 :=> _) -> True - _ -> False - - prop "Metadata (StorePath)" - $ \sd -> forAll (arbitrary `suchThat` (\m -> narHashIsSHA256 m && metadataNarBytes m /= Just 0)) - $ roundtripSReader @StoreDir pathMetadata sd + prop "Metadata (StorePath)" $ + roundtripSReader @StoreDir pathMetadata prop "Some HashAlgo" $ roundtripS someHashAlgo diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs index 60aae88..8cd26b6 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs @@ -4,6 +4,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} module System.Nix.Arbitrary.StorePath.Metadata where +import Data.Dependent.Sum (DSum((:=>))) import Data.HashSet.Arbitrary () import System.Nix.Arbitrary.ContentAddress () import System.Nix.Arbitrary.Hash () @@ -11,14 +12,24 @@ import System.Nix.Arbitrary.Signature () import System.Nix.Arbitrary.StorePath () import System.Nix.Arbitrary.UTCTime () import System.Nix.StorePath (StorePath) -import System.Nix.StorePath.Metadata (Metadata, StorePathTrust) +import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust) -import Test.QuickCheck (Arbitrary(..)) +import qualified System.Nix.Hash + +import Test.QuickCheck (Arbitrary(..), suchThat) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) deriving via GenericArbitrary StorePathTrust instance Arbitrary StorePathTrust -deriving via GenericArbitrary (Metadata StorePath) - instance Arbitrary (Metadata StorePath) - +instance Arbitrary (Metadata StorePath) where + arbitrary = do + metadataDeriverPath <- arbitrary + metadataNarHash <- (System.Nix.Hash.HashAlgo_SHA256 :=>) <$> arbitrary + metadataReferences <- arbitrary + metadataRegistrationTime <- arbitrary + metadataNarBytes <- arbitrary `suchThat` (/= Just 0) + metadataTrust <- arbitrary + metadataSigs <- arbitrary + metadataContentAddress <- arbitrary + pure Metadata{..} From 8936300fbe37fb38d9a167cab7922e8dbe29ce4b Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 19:38:02 +0100 Subject: [PATCH 065/104] core,remote: add OldBuildResult as it is the one we claim to support now --- hnix-store-core/src/System/Nix/Build.hs | 25 +++++++++++++------ .../src/System/Nix/Store/Remote.hs | 4 +-- .../src/System/Nix/Store/Remote/Serialize.hs | 18 +++++++++++-- .../src/System/Nix/Store/Remote/Serializer.hs | 17 +++++++++++-- hnix-store-remote/tests/NixSerializerSpec.hs | 1 + hnix-store-remote/tests/SerializeSpec.hs | 3 ++- .../src/System/Nix/Arbitrary/Build.hs | 3 +++ 7 files changed, 57 insertions(+), 14 deletions(-) diff --git a/hnix-store-core/src/System/Nix/Build.hs b/hnix-store-core/src/System/Nix/Build.hs index b28de93..f1367ac 100644 --- a/hnix-store-core/src/System/Nix/Build.hs +++ b/hnix-store-core/src/System/Nix/Build.hs @@ -5,15 +5,17 @@ Maintainer : srk module System.Nix.Build ( BuildMode(..) , BuildStatus(..) - , BuildResult(..) , buildSuccess + , BuildResult(..) + , OldBuildResult(..) ) where import Data.Time (UTCTime) import Data.Text (Text) import GHC.Generics (Generic) --- keep the order of these Enums to match enums from reference implementations +-- | Mode of the build operation +-- Keep the order of these Enums to match enums from reference implementations -- src/libstore/store-api.hh data BuildMode = BuildMode_Normal @@ -41,9 +43,9 @@ data BuildStatus = -- | Result of the build data BuildResult = BuildResult - { -- | build status, MiscFailure should be default + { -- | Build status, MiscFailure should be the default buildResultStatus :: !BuildStatus - , -- | possible build error message + , -- | Possible build error message buildResultErrorMessage :: !(Maybe Text) , -- | How many times this build was performed buildResultTimesBuilt :: !Int @@ -56,10 +58,19 @@ data BuildResult = BuildResult } deriving (Eq, Generic, Ord, Show) -buildSuccess :: BuildResult -> Bool -buildSuccess BuildResult {..} = - buildResultStatus `elem` +buildSuccess :: BuildStatus -> Bool +buildSuccess x = + x `elem` [ BuildStatus_Built , BuildStatus_Substituted , BuildStatus_AlreadyValid ] + +-- | Result of the build, for protocol version <= 1.27 +data OldBuildResult = OldBuildResult + { -- | Build status, MiscFailure should be the default + oldBuildResultStatus :: !BuildStatus + , -- | Possible build error message + oldBuildResultErrorMessage :: !(Maybe Text) + } + deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 1685d7b..66f4b3b 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -52,7 +52,7 @@ 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.Build (BuildMode, OldBuildResult) import System.Nix.Hash (NamedAlgo(..), BaseEncoding(Base16), decodeDigestWith) import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart, InvalidPathError) import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) @@ -226,7 +226,7 @@ buildDerivation :: StorePath -> Derivation StorePath Text -> BuildMode - -> MonadStore BuildResult + -> MonadStore OldBuildResult buildDerivation p drv buildMode = do storeDir <- getStoreDir runOpArgs WorkerOp_BuildDerivation $ do diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs index 2ac6d56..31a5304 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs @@ -20,7 +20,7 @@ import qualified Data.Text import qualified Data.Vector import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) -import System.Nix.Build (BuildMode(..), BuildStatus(..), BuildResult(..)) +import System.Nix.Build (BuildMode(..), BuildStatus(..), BuildResult(..), OldBuildResult(..)) import System.Nix.StorePath (StoreDir, StorePath) import System.Nix.Store.Remote.Serialize.Prim import System.Nix.Store.Remote.Types @@ -49,7 +49,7 @@ instance Serialize BuildResult where buildResultIsNonDeterministic <- getBool buildResultStartTime <- getTime buildResultStopTime <- getTime - pure $ BuildResult{..} + pure BuildResult{..} put BuildResult{..} = do put buildResultStatus @@ -61,6 +61,20 @@ instance Serialize BuildResult where putTime buildResultStartTime putTime buildResultStopTime +instance Serialize OldBuildResult where + get = do + oldBuildResultStatus <- get + oldBuildResultErrorMessage <- + (\em -> Data.Bool.bool (Just em) Nothing (Data.Text.null em)) + <$> get + pure OldBuildResult{..} + + put OldBuildResult{..} = do + put oldBuildResultStatus + case oldBuildResultErrorMessage of + Just err -> putText err + Nothing -> putText mempty + -- * GCAction -- instance Serialize GCAction where diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index c016fa4..d17f331 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -54,6 +54,7 @@ module System.Nix.Store.Remote.Serializer -- * Build , buildMode , buildResult + , oldBuildResult -- * Logger , LoggerSError(..) , activityID @@ -117,7 +118,7 @@ import qualified Data.Vector import Data.Serializer import System.Nix.Base (BaseEncoding(NixBase32)) -import System.Nix.Build (BuildMode, BuildResult(..)) +import System.Nix.Build (BuildMode, BuildResult(..), OldBuildResult(..)) import System.Nix.ContentAddress (ContentAddress) import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) import System.Nix.DerivedPath (DerivedPath, ParseOutputsError) @@ -710,7 +711,7 @@ buildResult = Serializer buildResultIsNonDeterministic <- getS bool buildResultStartTime <- getS time buildResultStopTime <- getS time - pure $ BuildResult{..} + pure BuildResult{..} , putS = \BuildResult{..} -> do putS enum buildResultStatus @@ -721,6 +722,18 @@ buildResult = Serializer putS time buildResultStopTime } +oldBuildResult :: NixSerializer r SError OldBuildResult +oldBuildResult = Serializer + { getS = do + oldBuildResultStatus <- getS enum + oldBuildResultErrorMessage <- getS maybeText + pure OldBuildResult{..} + + , putS = \OldBuildResult{..} -> do + putS enum oldBuildResultStatus + putS maybeText oldBuildResultErrorMessage + } + -- * Logger data LoggerSError diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index e9e913b..a573644 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -67,6 +67,7 @@ spec = parallel $ do describe "Complex" $ do prop "BuildResult" $ roundtripS buildResult + prop "OldBuildResult" $ roundtripS oldBuildResult prop "StorePath" $ roundtripSReader @StoreDir storePath diff --git a/hnix-store-remote/tests/SerializeSpec.hs b/hnix-store-remote/tests/SerializeSpec.hs index 51502e6..bea9177 100644 --- a/hnix-store-remote/tests/SerializeSpec.hs +++ b/hnix-store-remote/tests/SerializeSpec.hs @@ -14,7 +14,7 @@ import qualified Data.Either import qualified Data.HashSet import System.Nix.Arbitrary () -import System.Nix.Build (BuildMode(..), BuildResult, BuildStatus(..)) +import System.Nix.Build (BuildMode(..), BuildResult, BuildStatus(..), OldBuildResult(..)) import System.Nix.Derivation (Derivation(inputDrvs)) import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serialize (getDerivation, putDerivation) @@ -76,6 +76,7 @@ spec = parallel $ do prop "BuildMode" $ roundtripS @BuildMode prop "BuildStatus" $ roundtripS @BuildStatus prop "BuildResult" $ roundtripS @BuildResult + prop "OldBuildResult" $ roundtripS @OldBuildResult prop "ProtoVersion" $ roundtripS @ProtoVersion diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs index 1ff672c..1d6dd9e 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs @@ -27,3 +27,6 @@ instance Arbitrary BuildResult where buildResultStopTime <- arbitrary pure $ BuildResult{..} + +deriving via GenericArbitrary OldBuildResult + instance Arbitrary OldBuildResult From f93b21c58e3a40536b79ff38e96351fe7ec0cc1c Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 19:39:48 +0100 Subject: [PATCH 066/104] remote: maybe _ id -> fromMaybe _ --- .../src/System/Nix/Store/Remote/Serializer.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index d17f331..329071f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -108,6 +108,7 @@ import qualified Data.Bits import qualified Data.ByteString import qualified Data.HashSet import qualified Data.Map.Strict +import qualified Data.Maybe import qualified Data.Serialize.Get import qualified Data.Serialize.Put import qualified Data.Set @@ -338,7 +339,7 @@ maybeText = mapIsoSerializer t | Data.Text.null t -> Nothing t | otherwise -> Just t ) - (maybe mempty id) + (Data.Maybe.fromMaybe mempty) text -- * UTCTime @@ -534,7 +535,7 @@ pathMetadata = Serializer putS (hashSet storePath) metadataReferences putS time metadataRegistrationTime - putS int $ Prelude.maybe 0 id $ metadataNarBytes + putS int $ Data.Maybe.fromMaybe 0 metadataNarBytes putS storePathTrust metadataTrust putS (set narSignature) metadataSigs putS maybeContentAddress metadataContentAddress @@ -793,7 +794,7 @@ trace = Serializer traceHint <- mapPrimE $ getS text pure Trace{..} , putS = \Trace{..} -> do - maybe (putS (int @Int) 0) (putS int) $ tracePosition + putS int $ Data.Maybe.fromMaybe 0 tracePosition mapPrimE $ putS text traceHint } @@ -830,7 +831,7 @@ errorInfo = Serializer mapPrimE $ do putS text $ Data.Text.pack "Error" -- removed error name putS text errorInfoMessage - maybe (putS (int @Word8) 0) (putS int) errorInfoPosition + putS int $ Data.Maybe.fromMaybe 0 errorInfoPosition putS (list trace) errorInfoTraces } From 569e68fad5dbadd91fb8addd043ba561eec09395 Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 19:58:00 +0100 Subject: [PATCH 067/104] remote: drop no longer needed OverloadedStrings from Client --- hnix-store-remote/src/System/Nix/Store/Remote/Client.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 935eb5e..9848fc8 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module System.Nix.Store.Remote.Client ( Run , simpleOp From 06935815c6d640514fd495a53541d0bf03aa89d7 Mon Sep 17 00:00:00 2001 From: sorki Date: Mon, 4 Dec 2023 20:18:19 +0100 Subject: [PATCH 068/104] core: makeStorePathName -> mkStorePathName --- hnix-store-core/CHANGELOG.md | 1 + hnix-store-core/src/System/Nix/DerivedPath.hs | 2 +- hnix-store-core/src/System/Nix/StorePath.hs | 10 +++++----- hnix-store-readonly/tests/ReadOnlySpec.hs | 2 +- .../src/System/Nix/Store/Remote/Serializer.hs | 2 +- hnix-store-remote/tests-io/NixDaemon.hs | 6 +++--- hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs | 2 +- 7 files changed, 13 insertions(+), 12 deletions(-) diff --git a/hnix-store-core/CHANGELOG.md b/hnix-store-core/CHANGELOG.md index a9cd80d..e9e7cfd 100644 --- a/hnix-store-core/CHANGELOG.md +++ b/hnix-store-core/CHANGELOG.md @@ -1,6 +1,7 @@ # Next * Changes: + * `System.Nix.StorePath.makeStorePathName` renamed to `System.Nix.StorePath.mkStorePathName` * `System.Nix.ReadOnlyStore` moved to `hnix-store-readonly` package and renamed to `System.Nix.Store.ReadOnly` [#247](https://github.com/haskell-nix/hnix-store/pull/247) * `System.Nix.Nar*` moved to `hnix-store-nar` package [#247](https://github.com/haskell-nix/hnix-store/pull/247) diff --git a/hnix-store-core/src/System/Nix/DerivedPath.hs b/hnix-store-core/src/System/Nix/DerivedPath.hs index 2e886ce..fbcee8c 100644 --- a/hnix-store-core/src/System/Nix/DerivedPath.hs +++ b/hnix-store-core/src/System/Nix/DerivedPath.hs @@ -47,7 +47,7 @@ parseOutputsSpec t | t == "*" = Right OutputsSpec_All | otherwise = do names <- mapM - (convertError . System.Nix.StorePath.makeStorePathName) + (convertError . System.Nix.StorePath.mkStorePathName) (Data.Text.splitOn "," t) if null names then Left ParseOutputsError_NoNames diff --git a/hnix-store-core/src/System/Nix/StorePath.hs b/hnix-store-core/src/System/Nix/StorePath.hs index bbc3ff4..b112379 100644 --- a/hnix-store-core/src/System/Nix/StorePath.hs +++ b/hnix-store-core/src/System/Nix/StorePath.hs @@ -18,7 +18,7 @@ module System.Nix.StorePath , mkStorePathHashPart , unStorePathHashPart , -- * Manipulating 'StorePathName' - makeStorePathName + mkStorePathName , validStorePathName -- * Reason why a path is not valid , InvalidPathError(..) @@ -130,8 +130,8 @@ data InvalidPathError = -- | Make @StorePathName@ from @Text@ (name part of the @StorePath@) -- or fail with @InvalidPathError@ if it isn't valid -makeStorePathName :: Text -> Either InvalidPathError StorePathName -makeStorePathName n = +mkStorePathName :: Text -> Either InvalidPathError StorePathName +mkStorePathName n = if validStorePathName n then pure $ StorePathName n else Left $ reasonInvalid n @@ -224,7 +224,7 @@ parsePath' expectedRoot stringyPath = HashDecodingFailure StorePathHashPart $ System.Nix.Base.decodeWith NixBase32 storeBasedHashPart - name = makeStorePathName . Data.Text.drop 1 $ namePart + name = mkStorePathName . Data.Text.drop 1 $ namePart --rootDir' = dropTrailingPathSeparator rootDir -- cannot use ^^ as it drops multiple slashes /a/b/// -> /a/b rootDir' = init rootDir @@ -288,7 +288,7 @@ pathParser expectedRoot = do validStorePathNameChar "Path name contains invalid character" - let name = makeStorePathName $ Data.Text.cons c0 rest + let name = mkStorePathName $ Data.Text.cons c0 rest hashPart = Data.Bifunctor.bimap HashDecodingFailure StorePathHashPart diff --git a/hnix-store-readonly/tests/ReadOnlySpec.hs b/hnix-store-readonly/tests/ReadOnlySpec.hs index 6bab014..6d44967 100644 --- a/hnix-store-readonly/tests/ReadOnlySpec.hs +++ b/hnix-store-readonly/tests/ReadOnlySpec.hs @@ -21,7 +21,7 @@ testDigest = Crypto.Hash.hash @ByteString "testDigest" testName :: StorePathName testName = either undefined id - $ System.Nix.StorePath.makeStorePathName "testFixed" + $ System.Nix.StorePath.mkStorePathName "testFixed" testPath :: StorePath testPath = diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 329071f..f0905fb 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -494,7 +494,7 @@ storePathName :: NixSerializer r SError StorePathName storePathName = mapPrismSerializer (Data.Bifunctor.first SError_Path - . System.Nix.StorePath.makeStorePathName) + . System.Nix.StorePath.mkStorePathName) System.Nix.StorePath.unStorePathName text diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index 4c4e857..1a61242 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemon.hs @@ -163,12 +163,12 @@ withPath action = do -- | dummy path, adds /dummy with "Hello World" contents dummy :: MonadStore StorePath dummy = do - let name = Data.Either.fromRight (error "impossible") $ makeStorePathName "dummy" + let name = Data.Either.fromRight (error "impossible") $ mkStorePathName "dummy" addToStore @SHA256 name (dumpPath "dummy") FileIngestionMethod_Flat RepairMode_DontRepair invalidPath :: StorePath invalidPath = - let name = Data.Either.fromRight (error "impossible") $ makeStorePathName "invalid" + let name = Data.Either.fromRight (error "impossible") $ mkStorePathName "invalid" in unsafeMakeStorePath (mkStorePathHashPart @SHA256 "invalid") name withBuilder :: (StorePath -> MonadStore a) -> MonadStore a @@ -276,7 +276,7 @@ spec_protocol = Hspec.around withNixDaemon $ context "addToStore" $ itRights "adds file to store" $ do fp <- liftIO $ writeSystemTempFile "addition" "lal" - let name = Data.Either.fromRight (error "impossible") $ makeStorePathName "tmp-addition" + let name = Data.Either.fromRight (error "impossible") $ mkStorePathName "tmp-addition" res <- addToStore @SHA256 name (dumpPath fp) FileIngestionMethod_Flat RepairMode_DontRepair liftIO $ print res diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs index 9b75621..da8acc4 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs @@ -32,7 +32,7 @@ instance Arbitrary StorePath where instance Arbitrary StorePathName where arbitrary = either undefined id - . System.Nix.StorePath.makeStorePathName + . System.Nix.StorePath.mkStorePathName . Data.Text.pack <$> ((:) <$> s1 <*> listOf sn) where alphanum = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] From 9cf2e1aa34a7553dc57914ec6456be137d6cf789 Mon Sep 17 00:00:00 2001 From: sorki Date: Tue, 5 Dec 2023 06:22:08 +0100 Subject: [PATCH 069/104] core: split name part errors from InvalidPathError to InvalidNameError --- hnix-store-core/src/System/Nix/DerivedPath.hs | 20 ++++--- hnix-store-core/src/System/Nix/StorePath.hs | 54 ++++++++++++------- .../src/System/Nix/Store/Remote/Serializer.hs | 5 +- 3 files changed, 49 insertions(+), 30 deletions(-) diff --git a/hnix-store-core/src/System/Nix/DerivedPath.hs b/hnix-store-core/src/System/Nix/DerivedPath.hs index fbcee8c..b53772c 100644 --- a/hnix-store-core/src/System/Nix/DerivedPath.hs +++ b/hnix-store-core/src/System/Nix/DerivedPath.hs @@ -10,12 +10,12 @@ module System.Nix.DerivedPath ( , derivedPathToText ) where -import Data.Bifunctor (first) import GHC.Generics (Generic) import Data.Set (Set) import Data.Text (Text) -import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, InvalidPathError) +import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, InvalidNameError, InvalidPathError) +import qualified Data.Bifunctor import qualified Data.ByteString.Char8 import qualified Data.Set import qualified Data.Text @@ -33,21 +33,20 @@ data DerivedPath = data ParseOutputsError = ParseOutputsError_InvalidPath InvalidPathError + | ParseOutputsError_InvalidName InvalidNameError | ParseOutputsError_NoNames | ParseOutputsError_NoPrefix StoreDir Text deriving (Eq, Ord, Show) -convertError - :: Either InvalidPathError a - -> Either ParseOutputsError a -convertError = first ParseOutputsError_InvalidPath - parseOutputsSpec :: Text -> Either ParseOutputsError OutputsSpec parseOutputsSpec t | t == "*" = Right OutputsSpec_All | otherwise = do names <- mapM - (convertError . System.Nix.StorePath.mkStorePathName) + ( Data.Bifunctor.first + ParseOutputsError_InvalidName + . System.Nix.StorePath.mkStorePathName + ) (Data.Text.splitOn "," t) if null names then Left ParseOutputsError_NoNames @@ -89,6 +88,11 @@ parseDerivedPath root@(StoreDir sd) path = (textRoot <> pathNoPrefix) ) <*> parseOutputsSpec (Data.Text.drop (Data.Text.length "!") r) + where + convertError + :: Either InvalidPathError a + -> Either ParseOutputsError a + convertError = Data.Bifunctor.first ParseOutputsError_InvalidPath derivedPathToText :: StoreDir -> DerivedPath -> Text derivedPathToText root = \case diff --git a/hnix-store-core/src/System/Nix/StorePath.hs b/hnix-store-core/src/System/Nix/StorePath.hs index b112379..f172205 100644 --- a/hnix-store-core/src/System/Nix/StorePath.hs +++ b/hnix-store-core/src/System/Nix/StorePath.hs @@ -17,8 +17,9 @@ module System.Nix.StorePath , StorePathHashPart , mkStorePathHashPart , unStorePathHashPart - , -- * Manipulating 'StorePathName' - mkStorePathName + -- * Manipulating 'StorePathName' + , InvalidNameError(..) + , mkStorePathName , validStorePathName -- * Reason why a path is not valid , InvalidPathError(..) @@ -115,12 +116,17 @@ mkStorePathHashPart = StorePathHashPart . System.Nix.Hash.mkStorePathHash @hashAlgo --- | Reason why a path is not valid -data InvalidPathError = - EmptyName - | PathTooLong +-- | Reason why a path name or output name is not valid +data InvalidNameError + = EmptyName + | NameTooLong | LeadingDot | InvalidCharacter + deriving (Eq, Generic, Hashable, Ord, Show) + +-- | Reason why a path is not valid +data InvalidPathError + = PathNameInvalid InvalidNameError | HashDecodingFailure String | RootDirMismatch { rdMismatchExpected :: StoreDir @@ -129,17 +135,17 @@ data InvalidPathError = deriving (Eq, Generic, Hashable, Ord, Show) -- | Make @StorePathName@ from @Text@ (name part of the @StorePath@) --- or fail with @InvalidPathError@ if it isn't valid -mkStorePathName :: Text -> Either InvalidPathError StorePathName +-- or fail with @InvalidNameError@ if it isn't valid +mkStorePathName :: Text -> Either InvalidNameError StorePathName mkStorePathName n = if validStorePathName n then pure $ StorePathName n else Left $ reasonInvalid n -reasonInvalid :: Text -> InvalidPathError +reasonInvalid :: Text -> InvalidNameError reasonInvalid n | n == "" = EmptyName - | Data.Text.length n > 211 = PathTooLong + | Data.Text.length n > 211 = NameTooLong | Data.Text.head n == '.' = LeadingDot | otherwise = InvalidCharacter @@ -220,11 +226,15 @@ parsePath' expectedRoot stringyPath = let (rootDir, fname) = System.FilePath.splitFileName stringyPath (storeBasedHashPart, namePart) = Data.Text.breakOn "-" $ Data.Text.pack fname - hashPart = Data.Bifunctor.bimap - HashDecodingFailure - StorePathHashPart - $ System.Nix.Base.decodeWith NixBase32 storeBasedHashPart - name = mkStorePathName . Data.Text.drop 1 $ namePart + hashPart = + Data.Bifunctor.bimap + HashDecodingFailure + StorePathHashPart + $ System.Nix.Base.decodeWith NixBase32 storeBasedHashPart + name = + Data.Bifunctor.first + PathNameInvalid + $ mkStorePathName . Data.Text.drop 1 $ namePart --rootDir' = dropTrailingPathSeparator rootDir -- cannot use ^^ as it drops multiple slashes /a/b/// -> /a/b rootDir' = init rootDir @@ -288,11 +298,15 @@ pathParser expectedRoot = do validStorePathNameChar "Path name contains invalid character" - let name = mkStorePathName $ Data.Text.cons c0 rest - hashPart = Data.Bifunctor.bimap - HashDecodingFailure - StorePathHashPart - digest + let name = + Data.Bifunctor.first + PathNameInvalid + $ mkStorePathName $ Data.Text.cons c0 rest + hashPart = + Data.Bifunctor.bimap + HashDecodingFailure + StorePathHashPart + digest either (fail . show) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index f0905fb..e1cbd58 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -126,7 +126,7 @@ import System.Nix.DerivedPath (DerivedPath, ParseOutputsError) import System.Nix.Hash (HashAlgo(..)) import System.Nix.Signature (Signature, NarSignature) import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) -import System.Nix.StorePath (HasStoreDir(..), InvalidPathError, StorePath, StorePathHashPart, StorePathName) +import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) import System.Nix.Store.Remote.Types @@ -227,6 +227,7 @@ data SError | SError_InvalidNixBase32 | SError_NarHashMustBeSHA256 | SError_NotYetImplemented String (ForPV ProtoVersion) + | SError_Name InvalidNameError | SError_Path InvalidPathError | SError_Signature String deriving (Eq, Ord, Generic, Show) @@ -493,7 +494,7 @@ storePathHashPart = storePathName :: NixSerializer r SError StorePathName storePathName = mapPrismSerializer - (Data.Bifunctor.first SError_Path + (Data.Bifunctor.first SError_Name . System.Nix.StorePath.mkStorePathName) System.Nix.StorePath.unStorePathName text From 70443c884b6c2cc4483975c8b8ce2df4f31db05c Mon Sep 17 00:00:00 2001 From: sorki Date: Tue, 5 Dec 2023 07:38:35 +0100 Subject: [PATCH 070/104] core: improve mkStorePathName and its errors, add test --- hnix-store-core/hnix-store-core.cabal | 1 + hnix-store-core/src/System/Nix/StorePath.hs | 39 ++++++++++----------- hnix-store-core/tests/StorePath.hs | 38 ++++++++++++++++++++ 3 files changed, 57 insertions(+), 21 deletions(-) create mode 100644 hnix-store-core/tests/StorePath.hs diff --git a/hnix-store-core/hnix-store-core.cabal b/hnix-store-core/hnix-store-core.cabal index dcbffbd..bddd992 100644 --- a/hnix-store-core/hnix-store-core.cabal +++ b/hnix-store-core/hnix-store-core.cabal @@ -102,6 +102,7 @@ test-suite core Fingerprint Hash Signature + StorePath hs-source-dirs: tests build-tool-depends: diff --git a/hnix-store-core/src/System/Nix/StorePath.hs b/hnix-store-core/src/System/Nix/StorePath.hs index f172205..51488ba 100644 --- a/hnix-store-core/src/System/Nix/StorePath.hs +++ b/hnix-store-core/src/System/Nix/StorePath.hs @@ -20,7 +20,6 @@ module System.Nix.StorePath -- * Manipulating 'StorePathName' , InvalidNameError(..) , mkStorePathName - , validStorePathName -- * Reason why a path is not valid , InvalidPathError(..) , -- * Rendering out 'StorePath's @@ -119,9 +118,9 @@ mkStorePathHashPart = -- | Reason why a path name or output name is not valid data InvalidNameError = EmptyName - | NameTooLong + | NameTooLong Int | LeadingDot - | InvalidCharacter + | InvalidCharacters Text deriving (Eq, Generic, Hashable, Ord, Show) -- | Reason why a path is not valid @@ -137,24 +136,22 @@ data InvalidPathError -- | Make @StorePathName@ from @Text@ (name part of the @StorePath@) -- or fail with @InvalidNameError@ if it isn't valid mkStorePathName :: Text -> Either InvalidNameError StorePathName -mkStorePathName n = - if validStorePathName n - then pure $ StorePathName n - else Left $ reasonInvalid n - -reasonInvalid :: Text -> InvalidNameError -reasonInvalid n - | n == "" = EmptyName - | Data.Text.length n > 211 = NameTooLong - | Data.Text.head n == '.' = LeadingDot - | otherwise = InvalidCharacter - -validStorePathName :: Text -> Bool -validStorePathName n = - n /= "" - && Data.Text.length n <= 211 - && Data.Text.head n /= '.' - && Data.Text.all validStorePathNameChar n +mkStorePathName n + | n == "" + = Left EmptyName + | Data.Text.length n > 211 + = Left $ NameTooLong (Data.Text.length n) + | Data.Text.head n == '.' + = Left $ LeadingDot + | not + $ Data.Text.null + $ Data.Text.filter + (not . validStorePathNameChar) + n + = Left + $ InvalidCharacters + $ Data.Text.filter (not . validStorePathNameChar) n + | otherwise = pure $ StorePathName n validStorePathNameChar :: Char -> Bool validStorePathNameChar c = diff --git a/hnix-store-core/tests/StorePath.hs b/hnix-store-core/tests/StorePath.hs new file mode 100644 index 0000000..2ec3430 --- /dev/null +++ b/hnix-store-core/tests/StorePath.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module StorePath where + +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import qualified Data.Either +import qualified Data.Text + +import System.Nix.StorePath (mkStorePathName) + +spec_storePath :: Spec +spec_storePath = do + describe "StorePathName" $ do + it "parses valid name" $ + mkStorePathName "name-dev.dotok" + `shouldSatisfy` + Data.Either.isRight + + it "fails on empty" $ + mkStorePathName mempty + `shouldBe` + Left EmptyName + + it "fails on too long" $ + mkStorePathName (Data.Text.replicate 256 "n") + `shouldBe` + Left (NameTooLong 256) + + it "fails on leading dot" $ + mkStorePathName ".ab" + `shouldBe` + Left LeadingDot + + it "fails on invalid characters" $ + mkStorePathName "ab!cd#@" + `shouldBe` + Left (InvalidCharacters "!#@") From b8294ffb74190b12f800a58aa4d1b5a1ca2534a5 Mon Sep 17 00:00:00 2001 From: sorki Date: Tue, 5 Dec 2023 07:50:41 +0100 Subject: [PATCH 071/104] core: split parseNameText from mkStorePathName so it can be used for `OutputName` as well --- hnix-store-core/src/System/Nix/StorePath.hs | 9 +++++++-- hnix-store-core/tests/StorePath.hs | 21 ++++++++++----------- 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/hnix-store-core/src/System/Nix/StorePath.hs b/hnix-store-core/src/System/Nix/StorePath.hs index 51488ba..18bcf11 100644 --- a/hnix-store-core/src/System/Nix/StorePath.hs +++ b/hnix-store-core/src/System/Nix/StorePath.hs @@ -20,6 +20,7 @@ module System.Nix.StorePath -- * Manipulating 'StorePathName' , InvalidNameError(..) , mkStorePathName + , parseNameText -- * Reason why a path is not valid , InvalidPathError(..) , -- * Rendering out 'StorePath's @@ -136,7 +137,11 @@ data InvalidPathError -- | Make @StorePathName@ from @Text@ (name part of the @StorePath@) -- or fail with @InvalidNameError@ if it isn't valid mkStorePathName :: Text -> Either InvalidNameError StorePathName -mkStorePathName n +mkStorePathName = fmap StorePathName . parseNameText + +-- | Parse name (either @StorePathName@ or @OutputName@) +parseNameText :: Text -> Either InvalidNameError Text +parseNameText n | n == "" = Left EmptyName | Data.Text.length n > 211 @@ -151,7 +156,7 @@ mkStorePathName n = Left $ InvalidCharacters $ Data.Text.filter (not . validStorePathNameChar) n - | otherwise = pure $ StorePathName n + | otherwise = pure n validStorePathNameChar :: Char -> Bool validStorePathNameChar c = diff --git a/hnix-store-core/tests/StorePath.hs b/hnix-store-core/tests/StorePath.hs index 2ec3430..46a28f9 100644 --- a/hnix-store-core/tests/StorePath.hs +++ b/hnix-store-core/tests/StorePath.hs @@ -3,36 +3,35 @@ module StorePath where -import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) -import qualified Data.Either +import Test.Hspec (Spec, describe, it, shouldBe) import qualified Data.Text -import System.Nix.StorePath (mkStorePathName) +import System.Nix.StorePath (parseNameText, InvalidNameError(..)) spec_storePath :: Spec spec_storePath = do - describe "StorePathName" $ do + describe "parseNameText" $ do it "parses valid name" $ - mkStorePathName "name-dev.dotok" - `shouldSatisfy` - Data.Either.isRight + parseNameText "name-dev.dotok" + `shouldBe` + pure "name-dev.dotok" it "fails on empty" $ - mkStorePathName mempty + parseNameText mempty `shouldBe` Left EmptyName it "fails on too long" $ - mkStorePathName (Data.Text.replicate 256 "n") + parseNameText (Data.Text.replicate 256 "n") `shouldBe` Left (NameTooLong 256) it "fails on leading dot" $ - mkStorePathName ".ab" + parseNameText ".ab" `shouldBe` Left LeadingDot it "fails on invalid characters" $ - mkStorePathName "ab!cd#@" + parseNameText "ab!cd#@" `shouldBe` Left (InvalidCharacters "!#@") From 2f73cd9aef31cb184566c7d520e22b2345ca02b3 Mon Sep 17 00:00:00 2001 From: sorki Date: Tue, 5 Dec 2023 08:07:37 +0100 Subject: [PATCH 072/104] core: add System.Nix.OutputName --- hnix-store-core/hnix-store-core.cabal | 1 + hnix-store-core/src/System/Nix/DerivedPath.hs | 14 ++++++--- hnix-store-core/src/System/Nix/OutputName.hs | 29 +++++++++++++++++++ hnix-store-tests/hnix-store-tests.cabal | 1 + hnix-store-tests/src/System/Nix/Arbitrary.hs | 1 + .../src/System/Nix/Arbitrary/DerivedPath.hs | 1 + .../src/System/Nix/Arbitrary/OutputName.hs | 19 ++++++++++++ 7 files changed, 62 insertions(+), 4 deletions(-) create mode 100644 hnix-store-core/src/System/Nix/OutputName.hs create mode 100644 hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs diff --git a/hnix-store-core/hnix-store-core.cabal b/hnix-store-core/hnix-store-core.cabal index bddd992..6976b17 100644 --- a/hnix-store-core/hnix-store-core.cabal +++ b/hnix-store-core/hnix-store-core.cabal @@ -65,6 +65,7 @@ library , System.Nix.Fingerprint , System.Nix.Hash , System.Nix.Hash.Truncation + , System.Nix.OutputName , System.Nix.Signature , System.Nix.Store.Types , System.Nix.StorePath diff --git a/hnix-store-core/src/System/Nix/DerivedPath.hs b/hnix-store-core/src/System/Nix/DerivedPath.hs index b53772c..c53831f 100644 --- a/hnix-store-core/src/System/Nix/DerivedPath.hs +++ b/hnix-store-core/src/System/Nix/DerivedPath.hs @@ -13,17 +13,19 @@ module System.Nix.DerivedPath ( import GHC.Generics (Generic) import Data.Set (Set) import Data.Text (Text) -import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, InvalidNameError, InvalidPathError) +import System.Nix.OutputName (OutputName, InvalidNameError) +import System.Nix.StorePath (StoreDir(..), StorePath, InvalidPathError) import qualified Data.Bifunctor import qualified Data.ByteString.Char8 import qualified Data.Set import qualified Data.Text +import qualified System.Nix.OutputName import qualified System.Nix.StorePath data OutputsSpec = OutputsSpec_All - | OutputsSpec_Names (Set StorePathName) + | OutputsSpec_Names (Set OutputName) deriving (Eq, Generic, Ord, Show) data DerivedPath = @@ -45,7 +47,7 @@ parseOutputsSpec t names <- mapM ( Data.Bifunctor.first ParseOutputsError_InvalidName - . System.Nix.StorePath.mkStorePathName + . System.Nix.OutputName.mkOutputName ) (Data.Text.splitOn "," t) if null names @@ -56,7 +58,11 @@ outputsSpecToText :: OutputsSpec -> Text outputsSpecToText = \case OutputsSpec_All -> "*" OutputsSpec_Names ns -> - Data.Text.intercalate "," (fmap System.Nix.StorePath.unStorePathName (Data.Set.toList ns)) + Data.Text.intercalate + "," + (fmap System.Nix.OutputName.unOutputName + (Data.Set.toList ns) + ) parseDerivedPath :: StoreDir diff --git a/hnix-store-core/src/System/Nix/OutputName.hs b/hnix-store-core/src/System/Nix/OutputName.hs new file mode 100644 index 0000000..8634d5d --- /dev/null +++ b/hnix-store-core/src/System/Nix/OutputName.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-| +Description : Derived path output names +-} + +module System.Nix.OutputName + ( OutputName(..) + , mkOutputName + -- * Re-exports + , System.Nix.StorePath.InvalidNameError(..) + , System.Nix.StorePath.parseNameText + ) where + +import Data.Hashable (Hashable) +import Data.Text (Text) +import GHC.Generics (Generic) +import System.Nix.StorePath (InvalidNameError) + +import qualified System.Nix.StorePath + +-- | Name of the derived path output +-- Typically used for "dev", "doc" sub-outputs +newtype OutputName = OutputName + { -- | Extract the contents of the name. + unOutputName :: Text + } deriving (Eq, Generic, Hashable, Ord, Show) + +mkOutputName :: Text -> Either InvalidNameError OutputName +mkOutputName = fmap OutputName . System.Nix.StorePath.parseNameText diff --git a/hnix-store-tests/hnix-store-tests.cabal b/hnix-store-tests/hnix-store-tests.cabal index a6a3f97..b5ae247 100644 --- a/hnix-store-tests/hnix-store-tests.cabal +++ b/hnix-store-tests/hnix-store-tests.cabal @@ -46,6 +46,7 @@ library , System.Nix.Arbitrary.Derivation , System.Nix.Arbitrary.DerivedPath , System.Nix.Arbitrary.Hash + , System.Nix.Arbitrary.OutputName , System.Nix.Arbitrary.Signature , System.Nix.Arbitrary.Store.Types , System.Nix.Arbitrary.StorePath diff --git a/hnix-store-tests/src/System/Nix/Arbitrary.hs b/hnix-store-tests/src/System/Nix/Arbitrary.hs index e5020c5..96899f4 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary.hs @@ -11,6 +11,7 @@ import System.Nix.Arbitrary.ContentAddress () import System.Nix.Arbitrary.Derivation () import System.Nix.Arbitrary.DerivedPath () import System.Nix.Arbitrary.Hash () +import System.Nix.Arbitrary.OutputName () import System.Nix.Arbitrary.Signature () import System.Nix.Arbitrary.Store.Types () import System.Nix.Arbitrary.StorePath () diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs b/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs index 97918e3..1a3c56d 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs @@ -6,6 +6,7 @@ module System.Nix.Arbitrary.DerivedPath where import qualified Data.Set import Test.QuickCheck (Arbitrary(..), oneof) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) +import System.Nix.Arbitrary.OutputName () import System.Nix.Arbitrary.StorePath () import System.Nix.DerivedPath (DerivedPath, OutputsSpec(..)) diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs b/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs new file mode 100644 index 0000000..1fef8d6 --- /dev/null +++ b/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module System.Nix.Arbitrary.OutputName where + +import System.Nix.OutputName (OutputName) +import qualified Data.Text +import qualified System.Nix.OutputName + +import Test.QuickCheck (Arbitrary(arbitrary), elements, listOf) + +instance Arbitrary OutputName where + arbitrary = + either (error . show) id + . System.Nix.OutputName.mkOutputName + . Data.Text.pack <$> ((:) <$> s1 <*> listOf sn) + where + alphanum = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] + s1 = elements $ alphanum <> "+-_?=" + sn = elements $ alphanum <> "+-._?=" From 25778c1dcd75fb823343634c2f1247541196ddfd Mon Sep 17 00:00:00 2001 From: sorki Date: Tue, 5 Dec 2023 10:45:33 +0100 Subject: [PATCH 073/104] core: add System.Nix.Realisation --- hnix-store-core/hnix-store-core.cabal | 1 + hnix-store-core/src/System/Nix/Realisation.hs | 41 +++++++++++++++++++ hnix-store-tests/hnix-store-tests.cabal | 1 + hnix-store-tests/src/System/Nix/Arbitrary.hs | 1 + .../src/System/Nix/Arbitrary/Realisation.hs | 25 +++++++++++ 5 files changed, 69 insertions(+) create mode 100644 hnix-store-core/src/System/Nix/Realisation.hs create mode 100644 hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs diff --git a/hnix-store-core/hnix-store-core.cabal b/hnix-store-core/hnix-store-core.cabal index 6976b17..3b35b44 100644 --- a/hnix-store-core/hnix-store-core.cabal +++ b/hnix-store-core/hnix-store-core.cabal @@ -66,6 +66,7 @@ library , System.Nix.Hash , System.Nix.Hash.Truncation , System.Nix.OutputName + , System.Nix.Realisation , System.Nix.Signature , System.Nix.Store.Types , System.Nix.StorePath diff --git a/hnix-store-core/src/System/Nix/Realisation.hs b/hnix-store-core/src/System/Nix/Realisation.hs new file mode 100644 index 0000000..3ee2090 --- /dev/null +++ b/hnix-store-core/src/System/Nix/Realisation.hs @@ -0,0 +1,41 @@ +{-| +Description : Derivation realisations +-} + +module System.Nix.Realisation ( + DerivationOutput(..) + , Realisation(..) + ) where + +import Crypto.Hash (Digest) +import Data.Map (Map) +import Data.Set (Set) +import Data.Dependent.Sum (DSum) +import GHC.Generics (Generic) +import System.Nix.Hash (HashAlgo) +import System.Nix.OutputName (OutputName) +import System.Nix.Signature (Signature) +import System.Nix.StorePath (StorePath) + +-- | Output of the derivation +data DerivationOutput outputName = DerivationOutput + { derivationOutputHash :: DSum HashAlgo Digest + -- ^ Hash modulo of the derivation + , derivationOutputName :: outputName + -- ^ Name of the output + } deriving (Eq, Generic, Ord, Show) + +-- | Build realisation context +-- +-- realisationId is ommited since it is a key +-- of type @DerivationOutput OutputName@ so +-- we will use a tuple like @(DerivationOutput OutputName, Realisation)@ +-- instead. +data Realisation = Realisation + { realisationOutPath :: StorePath + -- ^ Output path + , realisationSignatures :: Set Signature + -- ^ Signatures + , realisationDependencies :: Map (DerivationOutput OutputName) StorePath + -- ^ Dependent realisations required for this one to be valid + } deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-tests/hnix-store-tests.cabal b/hnix-store-tests/hnix-store-tests.cabal index b5ae247..7c77c13 100644 --- a/hnix-store-tests/hnix-store-tests.cabal +++ b/hnix-store-tests/hnix-store-tests.cabal @@ -47,6 +47,7 @@ library , System.Nix.Arbitrary.DerivedPath , System.Nix.Arbitrary.Hash , System.Nix.Arbitrary.OutputName + , System.Nix.Arbitrary.Realisation , System.Nix.Arbitrary.Signature , System.Nix.Arbitrary.Store.Types , System.Nix.Arbitrary.StorePath diff --git a/hnix-store-tests/src/System/Nix/Arbitrary.hs b/hnix-store-tests/src/System/Nix/Arbitrary.hs index 96899f4..ff114d7 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary.hs @@ -12,6 +12,7 @@ import System.Nix.Arbitrary.Derivation () import System.Nix.Arbitrary.DerivedPath () import System.Nix.Arbitrary.Hash () import System.Nix.Arbitrary.OutputName () +import System.Nix.Arbitrary.Realisation () import System.Nix.Arbitrary.Signature () import System.Nix.Arbitrary.Store.Types () import System.Nix.Arbitrary.StorePath () diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs new file mode 100644 index 0000000..d5b6ab3 --- /dev/null +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs @@ -0,0 +1,25 @@ +-- due to recent generic-arbitrary +{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module System.Nix.Arbitrary.Realisation where + +import System.Nix.Arbitrary.Hash () +import System.Nix.Arbitrary.OutputName () +import System.Nix.Arbitrary.Signature () +import System.Nix.Arbitrary.StorePath () +import System.Nix.Realisation (DerivationOutput, Realisation) + +import Test.QuickCheck (Arbitrary(..)) +import Test.QuickCheck.Arbitrary.Generic (Arg, GenericArbitrary(..), genericArbitrary, genericShrink) + +instance + ( Arg (DerivationOutput outputName) outputName + , Arbitrary outputName + ) => + Arbitrary (DerivationOutput outputName) + where + arbitrary = genericArbitrary + shrink = genericShrink + +deriving via GenericArbitrary Realisation + instance Arbitrary Realisation From 72de93d260506b423d426119455a7e558e005806 Mon Sep 17 00:00:00 2001 From: sorki Date: Tue, 5 Dec 2023 10:56:50 +0100 Subject: [PATCH 074/104] core: improve haddocks for Build, use trailing haddocks for records --- hnix-store-core/src/System/Nix/Build.hs | 53 +++++++++++++------------ 1 file changed, 27 insertions(+), 26 deletions(-) diff --git a/hnix-store-core/src/System/Nix/Build.hs b/hnix-store-core/src/System/Nix/Build.hs index f1367ac..03ac1df 100644 --- a/hnix-store-core/src/System/Nix/Build.hs +++ b/hnix-store-core/src/System/Nix/Build.hs @@ -18,23 +18,24 @@ import GHC.Generics (Generic) -- Keep the order of these Enums to match enums from reference implementations -- src/libstore/store-api.hh data BuildMode - = BuildMode_Normal - | BuildMode_Repair - | BuildMode_Check + = BuildMode_Normal -- ^ Perform normal build + | BuildMode_Repair -- ^ Try to repair corrupted or missing paths by re-building or re-downloading them + | BuildMode_Check -- ^ Check if the build is reproducible (rebuild and compare to previous build) deriving (Eq, Generic, Ord, Enum, Show) +-- | Build result status data BuildStatus = - BuildStatus_Built - | BuildStatus_Substituted - | BuildStatus_AlreadyValid + BuildStatus_Built -- ^ Build performed successfully + | BuildStatus_Substituted -- ^ Path substituted from cache + | BuildStatus_AlreadyValid -- ^ Path is already valid (available in local store) | BuildStatus_PermanentFailure | BuildStatus_InputRejected | BuildStatus_OutputRejected - | BuildStatus_TransientFailure -- possibly transient - | BuildStatus_CachedFailure -- no longer used - | BuildStatus_TimedOut + | BuildStatus_TransientFailure -- ^ Possibly transient build failure + | BuildStatus_CachedFailure -- ^ Obsolete + | BuildStatus_TimedOut -- ^ Build timed out | BuildStatus_MiscFailure - | BuildStatus_DependencyFailed + | BuildStatus_DependencyFailed -- ^ Build dependency failed to build | BuildStatus_LogLimitExceeded | BuildStatus_NotDeterministic | BuildStatus_ResolvesToAlreadyValid @@ -43,18 +44,18 @@ data BuildStatus = -- | Result of the build data BuildResult = BuildResult - { -- | Build status, MiscFailure should be the default - buildResultStatus :: !BuildStatus - , -- | Possible build error message - buildResultErrorMessage :: !(Maybe Text) - , -- | How many times this build was performed - buildResultTimesBuilt :: !Int - , -- | If timesBuilt > 1, whether some builds did not produce the same result - buildResultIsNonDeterministic :: !Bool - , -- Start time of this build - buildResultStartTime :: !UTCTime - , -- Stop time of this build - buildResultStopTime :: !UTCTime + { buildResultStatus :: !BuildStatus + -- ^ Build status, MiscFailure should be the default + , buildResultErrorMessage :: !(Maybe Text) + -- ^ Possible build error message + , buildResultTimesBuilt :: !Int + -- ^ How many times this build was performed + , buildResultIsNonDeterministic :: !Bool + -- ^ If timesBuilt > 1, whether some builds did not produce the same result + , buildResultStartTime :: !UTCTime + -- ^ Start time of this build + , buildResultStopTime :: !UTCTime + -- ^ Stop time of this build } deriving (Eq, Generic, Ord, Show) @@ -68,9 +69,9 @@ buildSuccess x = -- | Result of the build, for protocol version <= 1.27 data OldBuildResult = OldBuildResult - { -- | Build status, MiscFailure should be the default - oldBuildResultStatus :: !BuildStatus - , -- | Possible build error message - oldBuildResultErrorMessage :: !(Maybe Text) + { oldBuildResultStatus :: !BuildStatus + -- ^ Build status, MiscFailure should be the default + , oldBuildResultErrorMessage :: !(Maybe Text) + -- ^ Possible build error message } deriving (Eq, Generic, Ord, Show) From 225b4d3f5a5f765c34af49b2c4672f485275e304 Mon Sep 17 00:00:00 2001 From: sorki Date: Tue, 5 Dec 2023 17:03:12 +0100 Subject: [PATCH 075/104] tests: limit the size of list for OutputName, StorePath name generators --- .../src/System/Nix/Arbitrary/OutputName.hs | 11 +++++++---- .../src/System/Nix/Arbitrary/StorePath.hs | 11 +++++++---- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs b/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs index 1fef8d6..0ef7ba2 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs @@ -6,14 +6,17 @@ import System.Nix.OutputName (OutputName) import qualified Data.Text import qualified System.Nix.OutputName -import Test.QuickCheck (Arbitrary(arbitrary), elements, listOf) +import Test.QuickCheck (Arbitrary(arbitrary), choose, elements, vectorOf) instance Arbitrary OutputName where arbitrary = either (error . show) id . System.Nix.OutputName.mkOutputName - . Data.Text.pack <$> ((:) <$> s1 <*> listOf sn) + . Data.Text.pack <$> ((:) <$> s1 <*> limited sn) where alphanum = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] - s1 = elements $ alphanum <> "+-_?=" - sn = elements $ alphanum <> "+-._?=" + s1 = elements $ alphanum <> "+-_?=" + sn = elements $ alphanum <> "+-._?=" + limited n = do + k <- choose (0, 210) + vectorOf k n diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs index da8acc4..c07c9b3 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs @@ -15,7 +15,7 @@ import System.Nix.StorePath (StoreDir(..) ) import qualified System.Nix.StorePath -import Test.QuickCheck (Arbitrary(arbitrary), elements, listOf, oneof) +import Test.QuickCheck (Arbitrary(arbitrary), choose, elements, oneof, vectorOf) instance Arbitrary StoreDir where arbitrary = @@ -33,11 +33,14 @@ instance Arbitrary StorePathName where arbitrary = either undefined id . System.Nix.StorePath.mkStorePathName - . Data.Text.pack <$> ((:) <$> s1 <*> listOf sn) + . Data.Text.pack <$> ((:) <$> s1 <*> limited sn) where alphanum = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] - s1 = elements $ alphanum <> "+-_?=" - sn = elements $ alphanum <> "+-._?=" + s1 = elements $ alphanum <> "+-_?=" + sn = elements $ alphanum <> "+-._?=" + limited n = do + k <- choose (0, 210) + vectorOf k n instance Arbitrary StorePathHashPart where arbitrary = From ee4ad7b07be14752b0029b723699664000fff0da Mon Sep 17 00:00:00 2001 From: sorki Date: Tue, 5 Dec 2023 17:04:29 +0100 Subject: [PATCH 076/104] add builtOutputs to BuildResult, more legwork --- hnix-store-core/src/System/Nix/Build.hs | 16 ++- .../src/System/Nix/Store/Remote/Serialize.hs | 3 + .../src/System/Nix/Store/Remote/Serializer.hs | 112 +++++++++++++++++- hnix-store-remote/tests/NixSerializerSpec.hs | 27 ++++- hnix-store-remote/tests/SerializeSpec.hs | 4 +- .../src/System/Nix/Arbitrary/Build.hs | 19 ++- 6 files changed, 167 insertions(+), 14 deletions(-) diff --git a/hnix-store-core/src/System/Nix/Build.hs b/hnix-store-core/src/System/Nix/Build.hs index 03ac1df..d7c81bc 100644 --- a/hnix-store-core/src/System/Nix/Build.hs +++ b/hnix-store-core/src/System/Nix/Build.hs @@ -10,10 +10,14 @@ module System.Nix.Build , OldBuildResult(..) ) where +import Data.Map (Map) import Data.Time (UTCTime) import Data.Text (Text) import GHC.Generics (Generic) +import System.Nix.OutputName (OutputName) +import System.Nix.Realisation (Realisation) + -- | Mode of the build operation -- Keep the order of these Enums to match enums from reference implementations -- src/libstore/store-api.hh @@ -56,6 +60,11 @@ data BuildResult = BuildResult -- ^ Start time of this build , buildResultStopTime :: !UTCTime -- ^ Stop time of this build + , buildResultBuiltOutputs :: !(Maybe (Map OutputName Realisation)) + -- ^ Mapping of the output names to @Realisation@s + -- (paths with additional info and their dependencies) + -- + -- Available for protocol version >= 1.28 } deriving (Eq, Generic, Ord, Show) @@ -67,11 +76,16 @@ buildSuccess x = , BuildStatus_AlreadyValid ] --- | Result of the build, for protocol version <= 1.27 +-- | Result of the build, for protocol version <= 1.28 data OldBuildResult = OldBuildResult { oldBuildResultStatus :: !BuildStatus -- ^ Build status, MiscFailure should be the default , oldBuildResultErrorMessage :: !(Maybe Text) -- ^ Possible build error message + , oldBuildResultBuiltOutputs :: !(Maybe (Map OutputName Realisation)) + -- ^ Mapping of the output names to @Realisation@s + -- (paths with additional info and their dependencies) + -- + -- Available for protocol version >= 1.28 } deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs index 31a5304..207b2bd 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs @@ -49,6 +49,8 @@ instance Serialize BuildResult where buildResultIsNonDeterministic <- getBool buildResultStartTime <- getTime buildResultStopTime <- getTime + + buildResultBuiltOutputs <- pure Nothing pure BuildResult{..} put BuildResult{..} = do @@ -67,6 +69,7 @@ instance Serialize OldBuildResult where oldBuildResultErrorMessage <- (\em -> Data.Bool.bool (Just em) Nothing (Data.Text.null em)) <$> get + oldBuildResultBuiltOutputs <- pure Nothing pure OldBuildResult{..} put OldBuildResult{..} = do diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index e1cbd58..74628e7 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -40,6 +40,11 @@ module System.Nix.Store.Remote.Serializer , storePathName -- * Metadata , pathMetadata + -- * OutputName + , outputName + -- * Realisation + , derivationOutputTyped + , realisation -- * Signatures , signature , narSignature @@ -47,6 +52,8 @@ module System.Nix.Store.Remote.Serializer , someHashAlgo -- * Digest , digest + -- * DSum HashAlgo Digest + , namedDigest -- * Derivation , derivation -- * Derivation @@ -96,6 +103,7 @@ import Data.Map (Map) import Data.Set (Set) import Data.Some (Some(Some)) import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) import Data.Time (NominalDiffTime, UTCTime) import Data.Vector (Vector) import Data.Word (Word8, Word32, Word64) @@ -114,6 +122,8 @@ import qualified Data.Serialize.Put import qualified Data.Set import qualified Data.Text import qualified Data.Text.Encoding +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder import qualified Data.Time.Clock.POSIX import qualified Data.Vector @@ -124,6 +134,8 @@ import System.Nix.ContentAddress (ContentAddress) import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) import System.Nix.DerivedPath (DerivedPath, ParseOutputsError) import System.Nix.Hash (HashAlgo(..)) +import System.Nix.OutputName (OutputName) +import System.Nix.Realisation (Realisation(..)) import System.Nix.Signature (Signature, NarSignature) import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) @@ -137,6 +149,8 @@ import qualified System.Nix.Base import qualified System.Nix.ContentAddress import qualified System.Nix.DerivedPath import qualified System.Nix.Hash +import qualified System.Nix.OutputName +import qualified System.Nix.Realisation import qualified System.Nix.Signature import qualified System.Nix.StorePath @@ -334,6 +348,12 @@ text = mapIsoSerializer Data.Text.Encoding.encodeUtf8 byteString +_textBuilder :: NixSerializer r SError Builder +_textBuilder = Serializer + { getS = Data.Text.Lazy.Builder.fromText <$> getS text + , putS = putS text . Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText + } + maybeText :: NixSerializer r SError (Maybe Text) maybeText = mapIsoSerializer (\case @@ -564,6 +584,44 @@ pathMetadata = Serializer (\case BuiltElsewhere -> False; BuiltLocally -> True) bool +-- * OutputName + +outputName :: NixSerializer r SError OutputName +outputName = + mapPrismSerializer + (Data.Bifunctor.first SError_Name + . System.Nix.OutputName.mkOutputName) + System.Nix.OutputName.unOutputName + text + +-- * Realisation + +derivationOutputTyped :: NixSerializer r SError (System.Nix.Realisation.DerivationOutput OutputName) +derivationOutputTyped = Serializer + { getS = do + derivationOutputHash <- getS namedDigest + derivationOutputName <- getS outputName + pure System.Nix.Realisation.DerivationOutput{..} + , putS = \System.Nix.Realisation.DerivationOutput{..} -> do + putS namedDigest derivationOutputHash + putS outputName derivationOutputName + } + +realisation + :: HasStoreDir r + => NixSerializer r SError Realisation +realisation = Serializer + { getS = do + realisationOutPath <- getS storePath + realisationSignatures <- getS (set signature) + realisationDependencies <- getS (mapS derivationOutputTyped storePath) + pure Realisation{..} + , putS = \Realisation{..} -> do + putS storePath realisationOutPath + putS (set signature) realisationSignatures + putS (mapS derivationOutputTyped storePath) realisationDependencies + } + -- * Signatures signature @@ -613,6 +671,28 @@ digest base = (System.Nix.Hash.encodeDigestWith base) $ text +-- * DSum HashAlgo Digest + +namedDigest :: NixSerializer r SError (DSum HashAlgo Digest) +namedDigest = Serializer + { getS = do + sriHash <- getS text + let (sriName, _h) = Data.Text.breakOn (Data.Text.singleton '-') sriHash + -- bit hacky since mkNamedDigest does the check + -- that the expected matches but we don't know + -- what we expect here (i.e. handle each HashAlgo) + case System.Nix.Hash.mkNamedDigest sriName sriHash of + Left e -> throwError $ SError_Digest e + Right x -> pure x + -- TODO: we also lack a builder for SRI hashes + -- , putS = putS textBuilder . System.Nix.Hash.algoDigestBuilder + , putS = \(algo :=> d) -> do + putS text + $ System.Nix.Hash.algoToText algo + <> (Data.Text.singleton '-') + <> System.Nix.Hash.encodeDigestWith NixBase32 d + } + derivationOutput :: HasStoreDir r => NixSerializer r SError (DerivationOutput StorePath Text) @@ -704,7 +784,11 @@ derivedPath = Serializer buildMode :: NixSerializer r SError BuildMode buildMode = enum -buildResult :: NixSerializer r SError BuildResult +buildResult + :: ( HasProtoVersion r + , HasStoreDir r + ) + => NixSerializer r SError BuildResult buildResult = Serializer { getS = do buildResultStatus <- getS enum @@ -713,6 +797,11 @@ buildResult = Serializer buildResultIsNonDeterministic <- getS bool buildResultStartTime <- getS time buildResultStopTime <- getS time + pv <- Control.Monad.Reader.asks hasProtoVersion + buildResultBuiltOutputs <- + if protoVersion_minor pv >= 28 + then pure <$> getS (mapS outputName realisation) + else pure Nothing pure BuildResult{..} , putS = \BuildResult{..} -> do @@ -722,18 +811,37 @@ buildResult = Serializer putS bool buildResultIsNonDeterministic putS time buildResultStartTime putS time buildResultStopTime + pv <- Control.Monad.Reader.asks hasProtoVersion + if protoVersion_minor pv >= 28 + then putS (mapS outputName realisation) + $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs + else pure () } -oldBuildResult :: NixSerializer r SError OldBuildResult +oldBuildResult + :: ( HasProtoVersion r + , HasStoreDir r + ) + => NixSerializer r SError OldBuildResult oldBuildResult = Serializer { getS = do oldBuildResultStatus <- getS enum oldBuildResultErrorMessage <- getS maybeText + pv <- Control.Monad.Reader.asks hasProtoVersion + oldBuildResultBuiltOutputs <- + if protoVersion_minor pv >= 28 + then pure <$> getS (mapS outputName realisation) + else pure Nothing pure OldBuildResult{..} , putS = \OldBuildResult{..} -> do putS enum oldBuildResultStatus putS maybeText oldBuildResultErrorMessage + pv <- Control.Monad.Reader.asks hasProtoVersion + if protoVersion_minor pv >= 28 + then putS (mapS outputName realisation) + $ Data.Maybe.fromMaybe mempty oldBuildResultBuiltOutputs + else pure () } -- * Logger diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index a573644..d789f8e 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -12,12 +12,13 @@ import Test.QuickCheck (Gen, arbitrary, forAll, suchThat) import System.Nix.Arbitrary () import System.Nix.Derivation (Derivation(inputDrvs)) +import System.Nix.Build (BuildResult(..)) import System.Nix.StorePath (StoreDir) import System.Nix.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 (TestStoreConfig(..)) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp(..)) @@ -66,8 +67,28 @@ spec = parallel $ do prop "mapS" $ roundtripS (mapS (int @Int) byteString) describe "Complex" $ do - prop "BuildResult" $ roundtripS buildResult - prop "OldBuildResult" $ roundtripS oldBuildResult + prop "DSum HashAlgo Digest" $ roundtripS namedDigest + + describe "BuildResult" $ do + prop "< 1.28" + $ \sd -> forAll (arbitrary `suchThat` ((< 28) . protoVersion_minor)) + $ \pv -> + roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv) + . (\x -> x { buildResultBuiltOutputs = Nothing }) + prop "= 1.28" + $ \sd -> + roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd (ProtoVersion 1 28)) + prop "> 1.28" + $ \sd -> forAll (arbitrary `suchThat` ((> 28) . protoVersion_minor)) + $ \pv -> + roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv) + +-- prop "OldBuildResult" +-- $ \testStoreConfig -> +-- forAll (arbitrary +-- `suchThat` +-- (restrictProtoVersionBuildResult (hasProtoVersion testStoreConfig))) +-- $ roundtripSReader oldBuildResult testStoreConfig prop "StorePath" $ roundtripSReader @StoreDir storePath diff --git a/hnix-store-remote/tests/SerializeSpec.hs b/hnix-store-remote/tests/SerializeSpec.hs index bea9177..c26313b 100644 --- a/hnix-store-remote/tests/SerializeSpec.hs +++ b/hnix-store-remote/tests/SerializeSpec.hs @@ -14,7 +14,7 @@ import qualified Data.Either import qualified Data.HashSet import System.Nix.Arbitrary () -import System.Nix.Build (BuildMode(..), BuildResult, BuildStatus(..), OldBuildResult(..)) +import System.Nix.Build (BuildMode(..), BuildStatus(..)) import System.Nix.Derivation (Derivation(inputDrvs)) import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serialize (getDerivation, putDerivation) @@ -75,8 +75,6 @@ spec = parallel $ do prop "Text" $ roundtripS @Text prop "BuildMode" $ roundtripS @BuildMode prop "BuildStatus" $ roundtripS @BuildStatus - prop "BuildResult" $ roundtripS @BuildResult - prop "OldBuildResult" $ roundtripS @OldBuildResult prop "ProtoVersion" $ roundtripS @ProtoVersion diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs index 1d6dd9e..e3d84a9 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs @@ -6,6 +6,8 @@ module System.Nix.Arbitrary.Build where import Data.Text.Arbitrary () import Test.QuickCheck (Arbitrary(..), suchThat) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) +import System.Nix.Arbitrary.OutputName () +import System.Nix.Arbitrary.Realisation () import System.Nix.Arbitrary.UTCTime () import System.Nix.Build @@ -19,14 +21,21 @@ deriving via GenericArbitrary BuildStatus instance Arbitrary BuildResult where arbitrary = do buildResultStatus <- arbitrary - -- we encode empty errorMessage as Nothing - buildResultErrorMessage <- arbitrary `suchThat` (/= Just mempty) + buildResultErrorMessage <- arbitrary buildResultTimesBuilt <- arbitrary buildResultIsNonDeterministic <- arbitrary buildResultStartTime <- arbitrary buildResultStopTime <- arbitrary + buildResultBuiltOutputs <- arbitrary `suchThat` (/= Nothing) + + pure BuildResult{..} + +instance Arbitrary OldBuildResult where + arbitrary = do + oldBuildResultStatus <- arbitrary + oldBuildResultErrorMessage <- arbitrary + oldBuildResultBuiltOutputs <- arbitrary `suchThat` (/= Just mempty) + + pure OldBuildResult{..} - pure $ BuildResult{..} -deriving via GenericArbitrary OldBuildResult - instance Arbitrary OldBuildResult From e6ed8f8069871b031a5c584fdba9d94eebe02958 Mon Sep 17 00:00:00 2001 From: sorki Date: Tue, 5 Dec 2023 19:32:29 +0100 Subject: [PATCH 077/104] single BuildResult to rule them all --- hnix-store-core/src/System/Nix/Build.hs | 41 +++-------- .../src/System/Nix/Store/Remote.hs | 28 +------ .../src/System/Nix/Store/Remote/Client.hs | 13 ++++ .../src/System/Nix/Store/Remote/Serialize.hs | 44 +---------- .../src/System/Nix/Store/Remote/Serializer.hs | 73 ++++++++----------- .../Nix/Store/Remote/Types/StoreReply.hs | 4 + hnix-store-remote/tests-io/NixDaemon.hs | 1 - hnix-store-remote/tests/NixSerializerSpec.hs | 19 +++-- .../src/System/Nix/Arbitrary/Build.hs | 28 +++---- 9 files changed, 89 insertions(+), 162 deletions(-) diff --git a/hnix-store-core/src/System/Nix/Build.hs b/hnix-store-core/src/System/Nix/Build.hs index d7c81bc..5d42860 100644 --- a/hnix-store-core/src/System/Nix/Build.hs +++ b/hnix-store-core/src/System/Nix/Build.hs @@ -7,7 +7,6 @@ module System.Nix.Build , BuildStatus(..) , buildSuccess , BuildResult(..) - , OldBuildResult(..) ) where import Data.Map (Map) @@ -48,23 +47,21 @@ data BuildStatus = -- | Result of the build data BuildResult = BuildResult - { buildResultStatus :: !BuildStatus + { buildResultStatus :: BuildStatus -- ^ Build status, MiscFailure should be the default - , buildResultErrorMessage :: !(Maybe Text) + , buildResultErrorMessage :: Maybe Text -- ^ Possible build error message - , buildResultTimesBuilt :: !Int - -- ^ How many times this build was performed - , buildResultIsNonDeterministic :: !Bool - -- ^ If timesBuilt > 1, whether some builds did not produce the same result - , buildResultStartTime :: !UTCTime - -- ^ Start time of this build - , buildResultStopTime :: !UTCTime - -- ^ Stop time of this build - , buildResultBuiltOutputs :: !(Maybe (Map OutputName Realisation)) - -- ^ Mapping of the output names to @Realisation@s + , buildResultTimesBuilt :: Maybe Int + -- ^ How many times this build was performed (since 1.29) + , buildResultIsNonDeterministic :: Maybe Bool + -- ^ If timesBuilt > 1, whether some builds did not produce the same result (since 1.29) + , buildResultStartTime :: Maybe UTCTime + -- ^ Start time of this build (since 1.29) + , buildResultStopTime :: Maybe UTCTime + -- ^ Stop time of this build (since 1.29) + , buildResultBuiltOutputs :: Maybe (Map OutputName Realisation) + -- ^ Mapping of the output names to @Realisation@s (since 1.28) -- (paths with additional info and their dependencies) - -- - -- Available for protocol version >= 1.28 } deriving (Eq, Generic, Ord, Show) @@ -75,17 +72,3 @@ buildSuccess x = , BuildStatus_Substituted , BuildStatus_AlreadyValid ] - --- | Result of the build, for protocol version <= 1.28 -data OldBuildResult = OldBuildResult - { oldBuildResultStatus :: !BuildStatus - -- ^ Build status, MiscFailure should be the default - , oldBuildResultErrorMessage :: !(Maybe Text) - -- ^ Possible build error message - , oldBuildResultBuiltOutputs :: !(Maybe (Map OutputName Realisation)) - -- ^ Mapping of the output names to @Realisation@s - -- (paths with additional info and their dependencies) - -- - -- Available for protocol version >= 1.28 - } - deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 66f4b3b..af830a7 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -11,7 +11,6 @@ module System.Nix.Store.Remote , addIndirectRoot , addTempRoot , buildPaths - , buildDerivation , deleteSpecific , ensurePath , findRoots @@ -30,6 +29,7 @@ module System.Nix.Store.Remote , syncWithGC , verifyStore , module System.Nix.Store.Types + , module System.Nix.Store.Remote.Client , module System.Nix.Store.Remote.MonadStore , module System.Nix.Store.Remote.Types -- * Compat @@ -50,9 +50,8 @@ 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, OldBuildResult) +import System.Nix.Build (BuildMode) import System.Nix.Hash (NamedAlgo(..), BaseEncoding(Base16), decodeDigestWith) import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart, InvalidPathError) import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) @@ -74,11 +73,9 @@ import qualified System.Nix.StorePath import System.Nix.Store.Remote.MonadStore (RemoteStoreT, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed)) import System.Nix.Store.Remote.Client (Run, runStoreSocket, runOp, runOpArgs, runOpArgsIO, simpleOp, simpleOpArgs) +import System.Nix.Store.Remote.Client (buildDerivation) import System.Nix.Store.Remote.Socket import System.Nix.Store.Remote.Types - -import Data.Serialize (get) -import System.Nix.Store.Remote.Serialize (putDerivation) import System.Nix.Store.Remote.Serialize.Prim -- * Compat @@ -222,25 +219,6 @@ buildPaths ps bm = do putPaths storeDir ps putInt $ fromEnum bm -buildDerivation - :: StorePath - -> Derivation StorePath Text - -> BuildMode - -> MonadStore OldBuildResult -buildDerivation p drv buildMode = do - storeDir <- getStoreDir - runOpArgs WorkerOp_BuildDerivation $ do - putPath storeDir p - putDerivation storeDir drv - putEnum buildMode - -- XXX: reason for this is unknown - -- but without it protocol just hangs waiting for - -- more data. Needs investigation. - -- Intentionally the only warning that should pop-up. - putInt (0 :: Int) - - getSocketIncremental get - -- | Delete store paths deleteSpecific :: HashSet StorePath -- ^ Paths to delete diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 9848fc8..9a102b9 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -9,6 +9,7 @@ module System.Nix.Store.Remote.Client , ourProtoVersion , doReq , addToStore + , buildDerivation , isValidPath ) where @@ -39,6 +40,10 @@ import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) +import Data.Text +import System.Nix.Build +import System.Nix.Derivation (Derivation) + simpleOp :: MonadRemoteStore m => WorkerOp @@ -146,6 +151,14 @@ addToStore name source method hashAlgo repair = do setNarSource source doReq (AddToStore name method hashAlgo repair) +buildDerivation + :: MonadRemoteStore m + => StorePath + -> Derivation StorePath Text + -> BuildMode + -> m BuildResult +buildDerivation a b c = doReq (BuildDerivation a b c) + --isValidPath :: MonadIO m => StorePath -> RemoteStoreT StoreConfig m Bool --isValidPath = doReq . IsValidPath diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs index 207b2bd..2480ae2 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs @@ -13,14 +13,13 @@ import Data.Word (Word8, Word32) import qualified Control.Monad import qualified Data.Bits -import qualified Data.Bool import qualified Data.Map import qualified Data.Set import qualified Data.Text import qualified Data.Vector +import System.Nix.Build (BuildMode, BuildStatus) import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) -import System.Nix.Build (BuildMode(..), BuildStatus(..), BuildResult(..), OldBuildResult(..)) import System.Nix.StorePath (StoreDir, StorePath) import System.Nix.Store.Remote.Serialize.Prim import System.Nix.Store.Remote.Types @@ -29,7 +28,7 @@ instance Serialize Text where get = getText put = putText --- * BuildResult +-- * Build instance Serialize BuildMode where get = getEnum @@ -39,45 +38,6 @@ instance Serialize BuildStatus where get = getEnum put = putEnum -instance Serialize BuildResult where - get = do - buildResultStatus <- get - buildResultErrorMessage <- - (\em -> Data.Bool.bool (Just em) Nothing (Data.Text.null em)) - <$> get - buildResultTimesBuilt <- getInt - buildResultIsNonDeterministic <- getBool - buildResultStartTime <- getTime - buildResultStopTime <- getTime - - buildResultBuiltOutputs <- pure Nothing - pure BuildResult{..} - - put BuildResult{..} = do - put buildResultStatus - case buildResultErrorMessage of - Just err -> putText err - Nothing -> putText mempty - putInt buildResultTimesBuilt - putBool buildResultIsNonDeterministic - putTime buildResultStartTime - putTime buildResultStopTime - -instance Serialize OldBuildResult where - get = do - oldBuildResultStatus <- get - oldBuildResultErrorMessage <- - (\em -> Data.Bool.bool (Just em) Nothing (Data.Text.null em)) - <$> get - oldBuildResultBuiltOutputs <- pure Nothing - pure OldBuildResult{..} - - put OldBuildResult{..} = do - put oldBuildResultStatus - case oldBuildResultErrorMessage of - Just err -> putText err - Nothing -> putText mempty - -- * GCAction -- instance Serialize GCAction where diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 74628e7..eb6ac06 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -61,7 +61,6 @@ module System.Nix.Store.Remote.Serializer -- * Build , buildMode , buildResult - , oldBuildResult -- * Logger , LoggerSError(..) , activityID @@ -129,7 +128,7 @@ import qualified Data.Vector import Data.Serializer import System.Nix.Base (BaseEncoding(NixBase32)) -import System.Nix.Build (BuildMode, BuildResult(..), OldBuildResult(..)) +import System.Nix.Build (BuildMode, BuildResult(..)) import System.Nix.ContentAddress (ContentAddress) import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) import System.Nix.DerivedPath (DerivedPath, ParseOutputsError) @@ -791,13 +790,25 @@ buildResult => NixSerializer r SError BuildResult buildResult = Serializer { getS = do + pv <- Control.Monad.Reader.asks hasProtoVersion + buildResultStatus <- getS enum buildResultErrorMessage <- getS maybeText - buildResultTimesBuilt <- getS int - buildResultIsNonDeterministic <- getS bool - buildResultStartTime <- getS time - buildResultStopTime <- getS time - pv <- Control.Monad.Reader.asks hasProtoVersion + + ( buildResultTimesBuilt + , buildResultIsNonDeterministic + , buildResultStartTime + , buildResultStopTime + ) <- + if protoVersion_minor pv >= 29 + then do + tb <- (\case 0 -> Nothing; x -> Just x) <$> getS int + nondet <- getS bool + start <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time + end <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time + pure $ (tb, pure nondet, start, end) + else pure $ (Nothing, Nothing, Nothing, Nothing) + buildResultBuiltOutputs <- if protoVersion_minor pv >= 28 then pure <$> getS (mapS outputName realisation) @@ -805,44 +816,22 @@ buildResult = Serializer pure BuildResult{..} , putS = \BuildResult{..} -> do + pv <- Control.Monad.Reader.asks hasProtoVersion + putS enum buildResultStatus putS maybeText buildResultErrorMessage - putS int buildResultTimesBuilt - putS bool buildResultIsNonDeterministic - putS time buildResultStartTime - putS time buildResultStopTime - pv <- Control.Monad.Reader.asks hasProtoVersion - if protoVersion_minor pv >= 28 - then putS (mapS outputName realisation) - $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs - else pure () - } - -oldBuildResult - :: ( HasProtoVersion r - , HasStoreDir r - ) - => NixSerializer r SError OldBuildResult -oldBuildResult = Serializer - { getS = do - oldBuildResultStatus <- getS enum - oldBuildResultErrorMessage <- getS maybeText - pv <- Control.Monad.Reader.asks hasProtoVersion - oldBuildResultBuiltOutputs <- - if protoVersion_minor pv >= 28 - then pure <$> getS (mapS outputName realisation) - else pure Nothing - pure OldBuildResult{..} - - , putS = \OldBuildResult{..} -> do - putS enum oldBuildResultStatus - putS maybeText oldBuildResultErrorMessage - pv <- Control.Monad.Reader.asks hasProtoVersion - if protoVersion_minor pv >= 28 - then putS (mapS outputName realisation) - $ Data.Maybe.fromMaybe mempty oldBuildResultBuiltOutputs - else pure () + Control.Monad.when (protoVersion_minor pv >= 29) $ do + putS int $ Data.Maybe.fromMaybe 0 buildResultTimesBuilt + putS bool $ Data.Maybe.fromMaybe False buildResultIsNonDeterministic + putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime + putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime + Control.Monad.when (protoVersion_minor pv >= 28) + $ putS (mapS outputName realisation) + $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs } + where + t0 :: UTCTime + t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 -- * Logger diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs index 33cbe6c..40421b9 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -2,6 +2,7 @@ module System.Nix.Store.Remote.Types.StoreReply ( StoreReply(..) ) where +import System.Nix.Build (BuildResult) import System.Nix.StorePath (HasStoreDir(..), StorePath) import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion) @@ -21,6 +22,9 @@ class StoreReply a where instance StoreReply Bool where getReplyS = mapPrimE bool +instance StoreReply BuildResult where + getReplyS = mapPrimE buildResult + instance StoreReply StorePath where getReplyS = mapPrimE storePath diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index 1a61242..a83a9c8 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.Client (Run) import System.Nix.Store.Remote.MonadStore (mapStoreConfig) import Crypto.Hash (SHA256) diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index d789f8e..fbdcaa3 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -75,21 +75,26 @@ spec = parallel $ do $ \pv -> roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv) . (\x -> x { buildResultBuiltOutputs = Nothing }) + . (\x -> x { buildResultTimesBuilt = Nothing + , buildResultIsNonDeterministic = Nothing + , buildResultStartTime = Nothing + , buildResultStopTime = Nothing + } + ) prop "= 1.28" $ \sd -> roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd (ProtoVersion 1 28)) + . (\x -> x { buildResultTimesBuilt = Nothing + , buildResultIsNonDeterministic = Nothing + , buildResultStartTime = Nothing + , buildResultStopTime = Nothing + } + ) prop "> 1.28" $ \sd -> forAll (arbitrary `suchThat` ((> 28) . protoVersion_minor)) $ \pv -> roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv) --- prop "OldBuildResult" --- $ \testStoreConfig -> --- forAll (arbitrary --- `suchThat` --- (restrictProtoVersionBuildResult (hasProtoVersion testStoreConfig))) --- $ roundtripSReader oldBuildResult testStoreConfig - prop "StorePath" $ roundtripSReader @StoreDir storePath diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs index e3d84a9..3cd2429 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs @@ -3,8 +3,9 @@ {-# OPTIONS_GHC -Wno-orphans #-} module System.Nix.Arbitrary.Build where +import Data.Time (UTCTime) import Data.Text.Arbitrary () -import Test.QuickCheck (Arbitrary(..), suchThat) +import Test.QuickCheck (Arbitrary(..), scale, suchThat) import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) import System.Nix.Arbitrary.OutputName () import System.Nix.Arbitrary.Realisation () @@ -12,6 +13,8 @@ import System.Nix.Arbitrary.UTCTime () import System.Nix.Build +import qualified Data.Time.Clock.POSIX + deriving via GenericArbitrary BuildMode instance Arbitrary BuildMode @@ -22,20 +25,13 @@ instance Arbitrary BuildResult where arbitrary = do buildResultStatus <- arbitrary buildResultErrorMessage <- arbitrary - buildResultTimesBuilt <- arbitrary - buildResultIsNonDeterministic <- arbitrary - buildResultStartTime <- arbitrary - buildResultStopTime <- arbitrary - buildResultBuiltOutputs <- arbitrary `suchThat` (/= Nothing) + buildResultTimesBuilt <- arbitrary `suchThat` (/= Just 0) + buildResultIsNonDeterministic <- arbitrary `suchThat` (/= Nothing) + buildResultStartTime <- arbitrary `suchThat` (/= Just t0) + buildResultStopTime <- arbitrary `suchThat` (/= Just t0) + buildResultBuiltOutputs <- scale (`div` 10) (arbitrary `suchThat` (/= Nothing)) pure BuildResult{..} - -instance Arbitrary OldBuildResult where - arbitrary = do - oldBuildResultStatus <- arbitrary - oldBuildResultErrorMessage <- arbitrary - oldBuildResultBuiltOutputs <- arbitrary `suchThat` (/= Just mempty) - - pure OldBuildResult{..} - - + where + t0 :: UTCTime + t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 From 1bda8fd1fe0a7bcc1d55029ac8a6ce1661f23cca Mon Sep 17 00:00:00 2001 From: sorki Date: Tue, 5 Dec 2023 19:34:44 +0100 Subject: [PATCH 078/104] add derivationOutput(Parser|Builder), prop --- hnix-store-core/src/System/Nix/Realisation.hs | 53 ++++++++++++++++++- .../src/System/Nix/Store/Remote/Serializer.hs | 25 +++++---- hnix-store-tests/hnix-store-tests.cabal | 1 + hnix-store-tests/tests/RealisationSpec.hs | 26 +++++++++ 4 files changed, 94 insertions(+), 11 deletions(-) create mode 100644 hnix-store-tests/tests/RealisationSpec.hs diff --git a/hnix-store-core/src/System/Nix/Realisation.hs b/hnix-store-core/src/System/Nix/Realisation.hs index 3ee2090..2cc00b2 100644 --- a/hnix-store-core/src/System/Nix/Realisation.hs +++ b/hnix-store-core/src/System/Nix/Realisation.hs @@ -4,19 +4,29 @@ Description : Derivation realisations module System.Nix.Realisation ( DerivationOutput(..) + , DerivationOutputError(..) + , derivationOutputBuilder + , derivationOutputParser , Realisation(..) ) where import Crypto.Hash (Digest) import Data.Map (Map) import Data.Set (Set) +import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) import Data.Dependent.Sum (DSum) import GHC.Generics (Generic) import System.Nix.Hash (HashAlgo) -import System.Nix.OutputName (OutputName) +import System.Nix.OutputName (OutputName, InvalidNameError) import System.Nix.Signature (Signature) import System.Nix.StorePath (StorePath) +import qualified Data.Bifunctor +import qualified Data.Text +import qualified Data.Text.Lazy.Builder +import qualified System.Nix.Hash + -- | Output of the derivation data DerivationOutput outputName = DerivationOutput { derivationOutputHash :: DSum HashAlgo Digest @@ -25,6 +35,47 @@ data DerivationOutput outputName = DerivationOutput -- ^ Name of the output } deriving (Eq, Generic, Ord, Show) +data DerivationOutputError + = DerivationOutputError_Digest String + | DerivationOutputError_Name InvalidNameError + | DerivationOutputError_NoExclamationMark + | DerivationOutputError_NoColon + | DerivationOutputError_TooManyParts [Text] + deriving (Eq, Ord, Show) + +derivationOutputParser + :: (Text -> Either InvalidNameError outputName) + -> Text + -> Either DerivationOutputError (DerivationOutput outputName) +derivationOutputParser outputName dOut = + case Data.Text.splitOn (Data.Text.singleton '!') dOut of + [] -> Left DerivationOutputError_NoColon + [sriHash, oName] -> do + hash <- + case Data.Text.splitOn (Data.Text.singleton ':') sriHash of + [] -> Left DerivationOutputError_NoColon + [hashName, digest] -> + Data.Bifunctor.first + DerivationOutputError_Digest + $ System.Nix.Hash.mkNamedDigest hashName digest + x -> Left $ DerivationOutputError_TooManyParts x + name <- + Data.Bifunctor.first + DerivationOutputError_Name + $ outputName oName + + pure $ DerivationOutput hash name + x -> Left $ DerivationOutputError_TooManyParts x + +derivationOutputBuilder + :: (outputName -> Text) + -> DerivationOutput outputName + -> Builder +derivationOutputBuilder outputName DerivationOutput{..} = + System.Nix.Hash.algoDigestBuilder derivationOutputHash + <> Data.Text.Lazy.Builder.singleton '!' + <> Data.Text.Lazy.Builder.fromText (outputName derivationOutputName) + -- | Build realisation context -- -- realisationId is ommited since it is a key diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index eb6ac06..f021a2e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -134,7 +134,7 @@ import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) import System.Nix.DerivedPath (DerivedPath, ParseOutputsError) import System.Nix.Hash (HashAlgo(..)) import System.Nix.OutputName (OutputName) -import System.Nix.Realisation (Realisation(..)) +import System.Nix.Realisation (DerivationOutputError, Realisation(..)) import System.Nix.Signature (Signature, NarSignature) import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) @@ -232,6 +232,7 @@ data SError } | SError_ContentAddress String | SError_DerivedPath ParseOutputsError + | SError_DerivationOutput DerivationOutputError | SError_Digest String | SError_EnumOutOfMinBound Int | SError_EnumOutOfMaxBound Int @@ -347,6 +348,7 @@ text = mapIsoSerializer Data.Text.Encoding.encodeUtf8 byteString +-- TODO Parser Builder _textBuilder :: NixSerializer r SError Builder _textBuilder = Serializer { getS = Data.Text.Lazy.Builder.fromText <$> getS text @@ -596,15 +598,18 @@ outputName = -- * Realisation derivationOutputTyped :: NixSerializer r SError (System.Nix.Realisation.DerivationOutput OutputName) -derivationOutputTyped = Serializer - { getS = do - derivationOutputHash <- getS namedDigest - derivationOutputName <- getS outputName - pure System.Nix.Realisation.DerivationOutput{..} - , putS = \System.Nix.Realisation.DerivationOutput{..} -> do - putS namedDigest derivationOutputHash - putS outputName derivationOutputName - } +derivationOutputTyped = + mapPrismSerializer + ( Data.Bifunctor.first SError_DerivationOutput + . System.Nix.Realisation.derivationOutputParser + System.Nix.OutputName.mkOutputName + ) + ( Data.Text.Lazy.toStrict + . Data.Text.Lazy.Builder.toLazyText + . System.Nix.Realisation.derivationOutputBuilder + System.Nix.OutputName.unOutputName + ) + text realisation :: HasStoreDir r diff --git a/hnix-store-tests/hnix-store-tests.cabal b/hnix-store-tests/hnix-store-tests.cabal index 7c77c13..e79dd67 100644 --- a/hnix-store-tests/hnix-store-tests.cabal +++ b/hnix-store-tests/hnix-store-tests.cabal @@ -80,6 +80,7 @@ test-suite props ContentAddressSpec DerivationSpec DerivedPathSpec + RealisationSpec StorePathSpec SignatureSpec hs-source-dirs: diff --git a/hnix-store-tests/tests/RealisationSpec.hs b/hnix-store-tests/tests/RealisationSpec.hs new file mode 100644 index 0000000..022b540 --- /dev/null +++ b/hnix-store-tests/tests/RealisationSpec.hs @@ -0,0 +1,26 @@ +module RealisationSpec where + +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.Hspec.Nix (roundtrips) + +import System.Nix.Arbitrary () + +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import qualified System.Nix.OutputName +import qualified System.Nix.Realisation + +spec :: Spec +spec = do + describe "DerivationOutput" $ do + prop "roundtrips" $ + roundtrips + ( Data.Text.Lazy.toStrict + . Data.Text.Lazy.Builder.toLazyText + . System.Nix.Realisation.derivationOutputBuilder + System.Nix.OutputName.unOutputName + ) + ( System.Nix.Realisation.derivationOutputParser + System.Nix.OutputName.mkOutputName + ) From 9c407cbf8ac083579498d675c4f9556b5a01dcda Mon Sep 17 00:00:00 2001 From: sorki Date: Wed, 6 Dec 2023 08:33:01 +0100 Subject: [PATCH 079/104] init hnix-store-json --- cabal.project | 1 + cabal.project.local.ci | 3 + default.nix | 1 + hie.yaml | 6 + hnix-store-json/CHANGELOG.md | 10 ++ hnix-store-json/LICENSE | 201 +++++++++++++++++++++++++ hnix-store-json/README.md | 3 + hnix-store-json/hnix-store-json.cabal | 64 ++++++++ hnix-store-json/src/System/Nix/JSON.hs | 143 ++++++++++++++++++ hnix-store-json/tests/JSONSpec.hs | 109 ++++++++++++++ hnix-store-json/tests/Spec.hs | 1 + overlay.nix | 6 + shell.nix | 1 + 13 files changed, 549 insertions(+) create mode 100644 hnix-store-json/CHANGELOG.md create mode 100644 hnix-store-json/LICENSE create mode 100644 hnix-store-json/README.md create mode 100644 hnix-store-json/hnix-store-json.cabal create mode 100644 hnix-store-json/src/System/Nix/JSON.hs create mode 100644 hnix-store-json/tests/JSONSpec.hs create mode 100644 hnix-store-json/tests/Spec.hs diff --git a/cabal.project b/cabal.project index fb9fabe..bec4b58 100644 --- a/cabal.project +++ b/cabal.project @@ -4,6 +4,7 @@ benchmarks: true packages: ./hnix-store-core/hnix-store-core.cabal ./hnix-store-db/hnix-store-db.cabal + ./hnix-store-json/hnix-store-json.cabal ./hnix-store-nar/hnix-store-nar.cabal ./hnix-store-readonly/hnix-store-readonly.cabal ./hnix-store-remote/hnix-store-remote.cabal diff --git a/cabal.project.local.ci b/cabal.project.local.ci index d97bf7d..764e06a 100644 --- a/cabal.project.local.ci +++ b/cabal.project.local.ci @@ -4,6 +4,9 @@ package hnix-store-core package hnix-store-db ghc-options: -Wunused-packages -Wall -Werror +package hnix-store-json + ghc-options: -Wunused-packages -Wall -Werror + package hnix-store-nar ghc-options: -Wunused-packages -Wall -Werror diff --git a/default.nix b/default.nix index 65722b4..f42d46e 100644 --- a/default.nix +++ b/default.nix @@ -22,6 +22,7 @@ in { inherit (haskellPackages) hnix-store-core hnix-store-db + hnix-store-json hnix-store-nar hnix-store-readonly hnix-store-remote diff --git a/hie.yaml b/hie.yaml index 9ba8d50..dc60850 100644 --- a/hie.yaml +++ b/hie.yaml @@ -12,6 +12,12 @@ cradle: - path: "./hnix-store-db/tests" component: "hnix-store-db:test:db" + - path: "./hnix-store-json/src" + component: "lib:hnix-store-json" + + - path: "./hnix-store-json/tests" + component: "hnix-store-json:test:json" + - path: "./hnix-store-nar/src" component: "lib:hnix-store-nar" diff --git a/hnix-store-json/CHANGELOG.md b/hnix-store-json/CHANGELOG.md new file mode 100644 index 0000000..b8e0d5f --- /dev/null +++ b/hnix-store-json/CHANGELOG.md @@ -0,0 +1,10 @@ +# Version [0.1.0.0](https://github.com/haskell-nix/hnix-store/compare/json-0.1.0.0...json-0.1.1.0) (2023-11-27) + +* Initial release + +--- + +`hnix-store-json` uses [PVP Versioning][1]. + +[1]: https://pvp.haskell.org + diff --git a/hnix-store-json/LICENSE b/hnix-store-json/LICENSE new file mode 100644 index 0000000..6b9e8a2 --- /dev/null +++ b/hnix-store-json/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2018 Shea Levy. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/hnix-store-json/README.md b/hnix-store-json/README.md new file mode 100644 index 0000000..ad23e4b --- /dev/null +++ b/hnix-store-json/README.md @@ -0,0 +1,3 @@ +# hnix-store-json + +Aeson instances for core types. diff --git a/hnix-store-json/hnix-store-json.cabal b/hnix-store-json/hnix-store-json.cabal new file mode 100644 index 0000000..08c4289 --- /dev/null +++ b/hnix-store-json/hnix-store-json.cabal @@ -0,0 +1,64 @@ +cabal-version: 2.2 +name: hnix-store-json +version: 0.1.0.0 +synopsis: JSON serialization for core types +description: + Aeson instances for core types +homepage: https://github.com/haskell-nix/hnix-store +license: Apache-2.0 +license-file: LICENSE +author: Richard Marko +maintainer: srk@48.io +copyright: 2023 Richard Marko +category: Nix +build-type: Simple +extra-source-files: + CHANGELOG.md + , README.md + +common commons + ghc-options: -Wall + default-extensions: + DataKinds + , DeriveAnyClass + , DeriveGeneric + , DerivingVia + , FlexibleInstances + , LambdaCase + , RecordWildCards + , StandaloneDeriving + , TypeApplications + default-language: Haskell2010 + +library + import: commons + exposed-modules: + System.Nix.JSON + build-depends: + base >=4.12 && <5 + , hnix-store-core >= 0.8 + , aeson >= 2.0 && < 3.0 + , attoparsec + , deriving-aeson >= 0.2 + , text + hs-source-dirs: src + +test-suite json + import: commons + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + JSONSpec + hs-source-dirs: + tests + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + base + , hnix-store-core + , hnix-store-json + , hnix-store-tests + , aeson + , containers + , data-default-class + , hspec diff --git a/hnix-store-json/src/System/Nix/JSON.hs b/hnix-store-json/src/System/Nix/JSON.hs new file mode 100644 index 0000000..6b944c3 --- /dev/null +++ b/hnix-store-json/src/System/Nix/JSON.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Description : JSON serialization + +This module is mostly a stub for now +providing (From|To)JSON for Realisation type +which is required for `-remote`. +-} +module System.Nix.JSON where + +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.Signature (Signature) +import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart) + +import qualified Data.Attoparsec.Text +import qualified Data.Char +import qualified Data.Text +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import qualified System.Nix.Base +import qualified System.Nix.OutputName +import qualified System.Nix.Realisation +import qualified System.Nix.Signature +import qualified System.Nix.StorePath + +instance ToJSON StorePathName where + toJSON = toJSON . System.Nix.StorePath.unStorePathName + toEncoding = toEncoding . System.Nix.StorePath.unStorePathName + +instance FromJSON StorePathName where + parseJSON = + withText "StorePathName" + ( either (fail . show) pure + . System.Nix.StorePath.mkStorePathName) + +instance ToJSON StorePathHashPart where + toJSON = toJSON . System.Nix.StorePath.storePathHashPartToText + toEncoding = toEncoding . System.Nix.StorePath.storePathHashPartToText + +instance FromJSON StorePathHashPart where + parseJSON = + withText "StorePathHashPart" + ( either + (fail . show) + (pure . System.Nix.StorePath.unsafeMakeStorePathHashPart) + . System.Nix.Base.decodeWith NixBase32 + ) + +instance ToJSON StorePath where + toJSON = + toJSON + -- TODO: hacky, we need to stop requiring StoreDir for + -- StorePath rendering and have a distinct + -- types for rooted|unrooted paths + . Data.Text.drop 1 + . System.Nix.StorePath.storePathToText (StoreDir mempty) + + toEncoding = + toEncoding + . Data.Text.drop 1 + . System.Nix.StorePath.storePathToText (StoreDir mempty) + +instance FromJSON StorePath where + parseJSON = + withText "StorePath" + ( either + (fail . show) + pure + . System.Nix.StorePath.parsePathFromText (StoreDir mempty) + . Data.Text.cons '/' + ) + +instance ToJSON (DerivationOutput OutputName) where + toJSON = + toJSON + . Data.Text.Lazy.toStrict + . Data.Text.Lazy.Builder.toLazyText + . System.Nix.Realisation.derivationOutputBuilder + System.Nix.OutputName.unOutputName + + toEncoding = + toEncoding + . Data.Text.Lazy.toStrict + . Data.Text.Lazy.Builder.toLazyText + . System.Nix.Realisation.derivationOutputBuilder + System.Nix.OutputName.unOutputName + +instance ToJSONKey (DerivationOutput OutputName) + +instance FromJSON (DerivationOutput OutputName) where + parseJSON = + withText "DerivationOutput OutputName" + ( either + (fail . show) + pure + . System.Nix.Realisation.derivationOutputParser + System.Nix.OutputName.mkOutputName + ) + +instance FromJSONKey (DerivationOutput OutputName) + +instance ToJSON Signature where + toJSON = toJSON . System.Nix.Signature.signatureToText + toEncoding = toEncoding . System.Nix.Signature.signatureToText + +instance FromJSON Signature where + parseJSON = + withText "Signature" + ( either + (fail . show) + pure + . Data.Attoparsec.Text.parseOnly + System.Nix.Signature.signatureParser + ) + +data LowerLeading +instance StringModifier LowerLeading where + getStringModifier "" = "" + getStringModifier (c:xs) = Data.Char.toLower c : xs + +deriving + via CustomJSON + '[FieldLabelModifier + '[ StripPrefix "realisation" + , LowerLeading + , Rename "dependencies" "dependentRealisations" + ] + ] Realisation + instance ToJSON Realisation +deriving + via CustomJSON + '[FieldLabelModifier + '[ StripPrefix "realisation" + , LowerLeading + , Rename "dependencies" "dependentRealisations" + ] + ] Realisation + instance FromJSON Realisation diff --git a/hnix-store-json/tests/JSONSpec.hs b/hnix-store-json/tests/JSONSpec.hs new file mode 100644 index 0000000..b7a6f91 --- /dev/null +++ b/hnix-store-json/tests/JSONSpec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} +module JSONSpec where + +import Data.Aeson (ToJSON, FromJSON, decode, encode) +import Data.Default.Class (Default(def)) +import Test.Hspec (Expectation, Spec, describe, it, shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.Hspec.Nix (roundtrips) + +import System.Nix.Arbitrary () +import System.Nix.JSON () +import System.Nix.OutputName (OutputName) +import System.Nix.Realisation (DerivationOutput(..), Realisation(..)) +import System.Nix.Signature (Signature) +import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) + +import qualified Data.Map +import qualified Data.Set +import qualified System.Nix.Hash +import qualified System.Nix.OutputName +import qualified System.Nix.Signature +import qualified System.Nix.StorePath + +roundtripsJSON + :: ( Eq a + , Show a + , ToJSON a + , FromJSON a + ) + => a + -> Expectation +roundtripsJSON = roundtrips encode decode + +sampleDerivationOutput :: DerivationOutput OutputName +sampleDerivationOutput = DerivationOutput + { derivationOutputHash = + forceRight + $ System.Nix.Hash.mkNamedDigest + "sha256" + "1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0" + , derivationOutputName = + forceRight + $ System.Nix.OutputName.mkOutputName "foo" + } + +sampleRealisation0 :: Realisation +sampleRealisation0 = Realisation + { realisationOutPath = + forceRight + $ System.Nix.StorePath.parsePath + def + "/nix/store/cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.sh" + , realisationSignatures = mempty + , realisationDependencies = mempty + } + +sampleRealisation1 :: Realisation +sampleRealisation1 = Realisation + { realisationOutPath = + forceRight + $ System.Nix.StorePath.parsePath + def + "/nix/store/5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv" + , realisationSignatures = + Data.Set.fromList + $ forceRight + . System.Nix.Signature.parseSignature + <$> [ "fW3iEMfyx6IZzGNswD54BjclfkXiYzh0xRXddrXfJ1rp1l8p1xTi9/0g2EibbwLFb6p83cwIJv5KtTGksC54CQ==" + , "SMjnB3mPgXYjXacU+xN24BdzXlAgGAuFnYwPddU3bhjfHBeQus/OimdIPMgR/JMKFPHXORrk7pbjv68vecTEBA==" + ] + , realisationDependencies = + Data.Map.fromList + [ ( sampleDerivationOutput + , forceRight + $ System.Nix.StorePath.parsePathFromText + def + "/nix/store/9472ijanf79nlkb5n1yh57s7867p1930-testFixed" + ) + ] + } + +spec :: Spec +spec = do + describe "JSON" $ do + describe "roundtrips" $ do + prop "StorePathName" $ roundtripsJSON @StorePathName + prop "StorePathHashPart" $ roundtripsJSON @StorePathHashPart + prop "StorePath" $ roundtripsJSON @StorePath + prop "DerivationOutput OutputName" $ roundtripsJSON @(DerivationOutput OutputName) + prop "Signature" $ roundtripsJSON @Signature + prop "Realisation" $ roundtripsJSON @Realisation + + describe "ground truth" $ do + it "sampleDerivationOutput matches preimage" $ + encode sampleDerivationOutput `shouldBe` "\"sha256:1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0!foo\"" + + it "sampleRealisation0 matches preimage" $ + encode sampleRealisation0 `shouldBe` "{\"outPath\":\"cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.sh\",\"signatures\":[],\"dependentRealisations\":[]}" + + it "sampleRealisation1 matches preimage" $ + encode sampleRealisation1 `shouldBe` "{\"outPath\":\"5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv\",\"signatures\":[\"SMjnB3mPgXYjXacU+xN24BdzXlAgGAuFnYwPddU3bhjfHBeQus/OimdIPMgR/JMKFPHXORrk7pbjv68vecTEBA==\",\"fW3iEMfyx6IZzGNswD54BjclfkXiYzh0xRXddrXfJ1rp1l8p1xTi9/0g2EibbwLFb6p83cwIJv5KtTGksC54CQ==\"],\"dependentRealisations\":[[\"sha256:1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0!foo\",\"9472ijanf79nlkb5n1yh57s7867p1930-testFixed\"]]}" + +forceRight + :: Show a + => Either a b + -> b +forceRight = \case + Right x -> x + Left e -> error $ "fromRight failed: " ++ show e diff --git a/hnix-store-json/tests/Spec.hs b/hnix-store-json/tests/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/hnix-store-json/tests/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/overlay.nix b/overlay.nix index a0d2558..75d7a34 100644 --- a/overlay.nix +++ b/overlay.nix @@ -56,6 +56,12 @@ in [ haskellLib.compose.buildFromSdist ]; + hnix-store-json = + lib.pipe + (hself.callCabal2nix "hnix-store-json" ./hnix-store-json {}) + [ + haskellLib.compose.buildFromSdist + ]; hnix-store-nar = lib.pipe (hself.callCabal2nix "hnix-store-nar" ./hnix-store-nar {}) diff --git a/shell.nix b/shell.nix index 72ff028..4dd2baf 100644 --- a/shell.nix +++ b/shell.nix @@ -6,6 +6,7 @@ let packages = [ "hnix-store-core" "hnix-store-db" + "hnix-store-json" "hnix-store-nar" "hnix-store-readonly" "hnix-store-remote" From f79effe092609941a91f6ce09ab1c4039e230c56 Mon Sep 17 00:00:00 2001 From: sorki Date: Wed, 6 Dec 2023 16:24:57 +0100 Subject: [PATCH 080/104] remote: fix handling of BuildResult.builtOutputs --- hnix-store-json/src/System/Nix/JSON.hs | 19 +++++++++++++-- hnix-store-json/tests/JSONSpec.hs | 4 ++-- hnix-store-remote/hnix-store-remote.cabal | 2 ++ .../src/System/Nix/Store/Remote/Serializer.hs | 23 +++++++++++-------- 4 files changed, 35 insertions(+), 13 deletions(-) diff --git a/hnix-store-json/src/System/Nix/JSON.hs b/hnix-store-json/src/System/Nix/JSON.hs index 6b944c3..fcbe152 100644 --- a/hnix-store-json/src/System/Nix/JSON.hs +++ b/hnix-store-json/src/System/Nix/JSON.hs @@ -10,6 +10,7 @@ which is required for `-remote`. module System.Nix.JSON where import Data.Aeson +import Data.Aeson.Types (toJSONKeyText) import Deriving.Aeson import System.Nix.Base (BaseEncoding(NixBase32)) import System.Nix.OutputName (OutputName) @@ -90,7 +91,13 @@ instance ToJSON (DerivationOutput OutputName) where . System.Nix.Realisation.derivationOutputBuilder System.Nix.OutputName.unOutputName -instance ToJSONKey (DerivationOutput OutputName) +instance ToJSONKey (DerivationOutput OutputName) where + toJSONKey = + toJSONKeyText + $ Data.Text.Lazy.toStrict + . Data.Text.Lazy.Builder.toLazyText + . System.Nix.Realisation.derivationOutputBuilder + System.Nix.OutputName.unOutputName instance FromJSON (DerivationOutput OutputName) where parseJSON = @@ -102,7 +109,15 @@ instance FromJSON (DerivationOutput OutputName) where System.Nix.OutputName.mkOutputName ) -instance FromJSONKey (DerivationOutput OutputName) +instance FromJSONKey (DerivationOutput OutputName) where + fromJSONKey = + FromJSONKeyTextParser + ( either + (fail . show) + pure + . System.Nix.Realisation.derivationOutputParser + System.Nix.OutputName.mkOutputName + ) instance ToJSON Signature where toJSON = toJSON . System.Nix.Signature.signatureToText diff --git a/hnix-store-json/tests/JSONSpec.hs b/hnix-store-json/tests/JSONSpec.hs index b7a6f91..d5e0eac 100644 --- a/hnix-store-json/tests/JSONSpec.hs +++ b/hnix-store-json/tests/JSONSpec.hs @@ -95,10 +95,10 @@ spec = do encode sampleDerivationOutput `shouldBe` "\"sha256:1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0!foo\"" it "sampleRealisation0 matches preimage" $ - encode sampleRealisation0 `shouldBe` "{\"outPath\":\"cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.sh\",\"signatures\":[],\"dependentRealisations\":[]}" + encode sampleRealisation0 `shouldBe` "{\"outPath\":\"cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.sh\",\"signatures\":[],\"dependentRealisations\":{}}" it "sampleRealisation1 matches preimage" $ - encode sampleRealisation1 `shouldBe` "{\"outPath\":\"5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv\",\"signatures\":[\"SMjnB3mPgXYjXacU+xN24BdzXlAgGAuFnYwPddU3bhjfHBeQus/OimdIPMgR/JMKFPHXORrk7pbjv68vecTEBA==\",\"fW3iEMfyx6IZzGNswD54BjclfkXiYzh0xRXddrXfJ1rp1l8p1xTi9/0g2EibbwLFb6p83cwIJv5KtTGksC54CQ==\"],\"dependentRealisations\":[[\"sha256:1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0!foo\",\"9472ijanf79nlkb5n1yh57s7867p1930-testFixed\"]]}" + encode sampleRealisation1 `shouldBe` "{\"outPath\":\"5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv\",\"signatures\":[\"SMjnB3mPgXYjXacU+xN24BdzXlAgGAuFnYwPddU3bhjfHBeQus/OimdIPMgR/JMKFPHXORrk7pbjv68vecTEBA==\",\"fW3iEMfyx6IZzGNswD54BjclfkXiYzh0xRXddrXfJ1rp1l8p1xTi9/0g2EibbwLFb6p83cwIJv5KtTGksC54CQ==\"],\"dependentRealisations\":{\"sha256:1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0!foo\":\"9472ijanf79nlkb5n1yh57s7867p1930-testFixed\"}}" forceRight :: Show a diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index ae3843b..f3fd7c3 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -107,8 +107,10 @@ library build-depends: base >=4.12 && <5 , hnix-store-core >= 0.8 && <0.9 + , hnix-store-json >= 0.1 , hnix-store-nar >= 0.1 , hnix-store-tests >= 0.1 + , aeson , attoparsec , bytestring , cereal diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index f021a2e..d7f3583 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -113,6 +113,7 @@ import qualified Control.Monad.Reader import qualified Data.Attoparsec.Text import qualified Data.Bits import qualified Data.ByteString +import qualified Data.ByteString.Lazy import qualified Data.HashSet import qualified Data.Map.Strict import qualified Data.Maybe @@ -133,6 +134,7 @@ import System.Nix.ContentAddress (ContentAddress) import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) import System.Nix.DerivedPath (DerivedPath, ParseOutputsError) import System.Nix.Hash (HashAlgo(..)) +import System.Nix.JSON () import System.Nix.OutputName (OutputName) import System.Nix.Realisation (DerivationOutputError, Realisation(..)) import System.Nix.Signature (Signature, NarSignature) @@ -141,6 +143,7 @@ import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) import System.Nix.Store.Remote.Types +import qualified Data.Aeson import qualified Data.Coerce import qualified Data.Bifunctor import qualified Data.Some @@ -616,14 +619,11 @@ realisation => NixSerializer r SError Realisation realisation = Serializer { getS = do - realisationOutPath <- getS storePath - realisationSignatures <- getS (set signature) - realisationDependencies <- getS (mapS derivationOutputTyped storePath) - pure Realisation{..} - , putS = \Realisation{..} -> do - putS storePath realisationOutPath - putS (set signature) realisationSignatures - putS (mapS derivationOutputTyped storePath) realisationDependencies + rb <- getS byteString + case Data.Aeson.eitherDecode (Data.ByteString.Lazy.fromStrict rb) of + Left e -> error e + Right r -> pure r + , putS = putS byteString . Data.ByteString.Lazy.toStrict . Data.Aeson.encode } -- * Signatures @@ -816,7 +816,11 @@ buildResult = Serializer buildResultBuiltOutputs <- if protoVersion_minor pv >= 28 - then pure <$> getS (mapS outputName realisation) + then + pure + . Data.Map.Strict.mapKeys + System.Nix.Realisation.derivationOutputName + <$> getS (mapS derivationOutputTyped realisation) else pure Nothing pure BuildResult{..} @@ -831,6 +835,7 @@ buildResult = Serializer putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime Control.Monad.when (protoVersion_minor pv >= 28) + -- TODO realisation.id $ putS (mapS outputName realisation) $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs } From e6d21c15bc0543b5b7df0d880e334f432cbac0b2 Mon Sep 17 00:00:00 2001 From: sorki Date: Wed, 6 Dec 2023 18:34:18 +0100 Subject: [PATCH 081/104] remote: deal with Realisation.id (required for the server side and qc prop) --- hnix-store-core/src/System/Nix/Build.hs | 4 +- hnix-store-json/src/System/Nix/JSON.hs | 22 +++++++- .../src/System/Nix/Store/Remote/Serializer.hs | 50 +++++++++++++------ 3 files changed, 56 insertions(+), 20 deletions(-) diff --git a/hnix-store-core/src/System/Nix/Build.hs b/hnix-store-core/src/System/Nix/Build.hs index 5d42860..248732d 100644 --- a/hnix-store-core/src/System/Nix/Build.hs +++ b/hnix-store-core/src/System/Nix/Build.hs @@ -15,7 +15,7 @@ import Data.Text (Text) import GHC.Generics (Generic) import System.Nix.OutputName (OutputName) -import System.Nix.Realisation (Realisation) +import System.Nix.Realisation (DerivationOutput, Realisation) -- | Mode of the build operation -- Keep the order of these Enums to match enums from reference implementations @@ -59,7 +59,7 @@ data BuildResult = BuildResult -- ^ Start time of this build (since 1.29) , buildResultStopTime :: Maybe UTCTime -- ^ Stop time of this build (since 1.29) - , buildResultBuiltOutputs :: Maybe (Map OutputName Realisation) + , buildResultBuiltOutputs :: Maybe (Map (DerivationOutput OutputName) Realisation) -- ^ Mapping of the output names to @Realisation@s (since 1.28) -- (paths with additional info and their dependencies) } diff --git a/hnix-store-json/src/System/Nix/JSON.hs b/hnix-store-json/src/System/Nix/JSON.hs index fcbe152..12a951d 100644 --- a/hnix-store-json/src/System/Nix/JSON.hs +++ b/hnix-store-json/src/System/Nix/JSON.hs @@ -10,7 +10,6 @@ which is required for `-remote`. module System.Nix.JSON where import Data.Aeson -import Data.Aeson.Types (toJSONKeyText) import Deriving.Aeson import System.Nix.Base (BaseEncoding(NixBase32)) import System.Nix.OutputName (OutputName) @@ -18,6 +17,8 @@ import System.Nix.Realisation (DerivationOutput, Realisation) import System.Nix.Signature (Signature) import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart) +import qualified Data.Aeson.KeyMap +import qualified Data.Aeson.Types import qualified Data.Attoparsec.Text import qualified Data.Char import qualified Data.Text @@ -93,7 +94,7 @@ instance ToJSON (DerivationOutput OutputName) where instance ToJSONKey (DerivationOutput OutputName) where toJSONKey = - toJSONKeyText + Data.Aeson.Types.toJSONKeyText $ Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText . System.Nix.Realisation.derivationOutputBuilder @@ -156,3 +157,20 @@ deriving ] ] Realisation instance FromJSON Realisation + +-- For a keyed version of Realisation +-- we use (DerivationOutput OutputName, Realisation) +-- instead of Realisation.id :: (DerivationOutput OutputName) +-- field. +instance {-# OVERLAPPING #-} ToJSON (DerivationOutput OutputName, Realisation) where + toJSON (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 + parseJSON v@(Object o) = do + r <- parseJSON @Realisation v + drvOut <- o .: "id" + pure (drvOut, r) + parseJSON x = fail $ "Expected Object but got " ++ show x diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index d7f3583..a9fbf28 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -31,6 +31,8 @@ module System.Nix.Store.Remote.Serializer , set , hashSet , mapS + , vector + , json -- * ProtoVersion , protoVersion -- * StorePath @@ -45,6 +47,7 @@ module System.Nix.Store.Remote.Serializer -- * Realisation , derivationOutputTyped , realisation + , realisationWithId -- * Signatures , signature , narSignature @@ -93,6 +96,7 @@ import Control.Monad.Trans (MonadTrans, lift) import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT) import Control.Monad.Trans.Except (ExceptT, mapExceptT, runExceptT, withExceptT) import Crypto.Hash (Digest, HashAlgorithm, SHA256) +import Data.Aeson (FromJSON, ToJSON) import Data.ByteString (ByteString) import Data.Dependent.Sum (DSum((:=>))) import Data.Fixed (Uni) @@ -242,6 +246,7 @@ data SError | SError_HashAlgo String | SError_IllegalBool Word64 | SError_InvalidNixBase32 + | SError_JSONDecoding String | SError_NarHashMustBeSHA256 | SError_NotYetImplemented String (ForPV ProtoVersion) | SError_Name InvalidNameError @@ -447,6 +452,22 @@ vector = Data.Vector.toList . list +json + :: ( FromJSON a + , ToJSON a + ) + => NixSerializer r SError a +json = + mapPrismSerializer + ( Data.Bifunctor.first SError_JSONDecoding + . Data.Aeson.eitherDecode + ) + Data.Aeson.encode + $ mapIsoSerializer + Data.ByteString.Lazy.fromStrict + Data.ByteString.Lazy.toStrict + byteString + -- * ProtoVersion -- protoVersion_major & 0xFF00 @@ -614,17 +635,11 @@ derivationOutputTyped = ) text -realisation - :: HasStoreDir r - => NixSerializer r SError Realisation -realisation = Serializer - { getS = do - rb <- getS byteString - case Data.Aeson.eitherDecode (Data.ByteString.Lazy.fromStrict rb) of - Left e -> error e - Right r -> pure r - , putS = putS byteString . Data.ByteString.Lazy.toStrict . Data.Aeson.encode - } +realisation :: NixSerializer r SError Realisation +realisation = json + +realisationWithId :: NixSerializer r SError (System.Nix.Realisation.DerivationOutput OutputName, Realisation) +realisationWithId = json -- * Signatures @@ -818,9 +833,10 @@ buildResult = Serializer if protoVersion_minor pv >= 28 then pure - . Data.Map.Strict.mapKeys - System.Nix.Realisation.derivationOutputName - <$> getS (mapS derivationOutputTyped realisation) + . Data.Map.Strict.fromList + . map (\(_, (a, b)) -> (a, b)) + . Data.Map.Strict.toList + <$> getS (mapS derivationOutputTyped realisationWithId) else pure Nothing pure BuildResult{..} @@ -835,8 +851,10 @@ buildResult = Serializer putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime Control.Monad.when (protoVersion_minor pv >= 28) - -- TODO realisation.id - $ putS (mapS outputName realisation) + $ putS (mapS derivationOutputTyped realisationWithId) + $ Data.Map.Strict.fromList + $ map (\(a, b) -> (a, (a, b))) + $ Data.Map.Strict.toList $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs } where From 496fb3284e787f6a232f19a55cdb41ae745e0eec Mon Sep 17 00:00:00 2001 From: sorki Date: Wed, 6 Dec 2023 18:36:22 +0100 Subject: [PATCH 082/104] make DerivationOutput explicitely generic It is already parametrized, but `name` field is too specific to accommodate i.e. `DerivationOutput StorePath` which is used by `Derivation` type. So we call it `output` instead and turn the type variable to just `a`. So * for `Realisation`s this is `DerivationOutput OutputName` * for `Derivation`s this is `DerivatonOutput StorePath` * for content addressed derivations this might be `DerivationOutput Void` as the path isn't known ahead of time. So only its shape is important. Related to https://github.com/Gabriella439/Haskell-Nix-Derivation-Library/pull/24 --- hnix-store-core/src/System/Nix/Realisation.hs | 8 ++++---- hnix-store-json/tests/JSONSpec.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/hnix-store-core/src/System/Nix/Realisation.hs b/hnix-store-core/src/System/Nix/Realisation.hs index 2cc00b2..383fd17 100644 --- a/hnix-store-core/src/System/Nix/Realisation.hs +++ b/hnix-store-core/src/System/Nix/Realisation.hs @@ -28,11 +28,11 @@ import qualified Data.Text.Lazy.Builder import qualified System.Nix.Hash -- | Output of the derivation -data DerivationOutput outputName = DerivationOutput +data DerivationOutput a = DerivationOutput { derivationOutputHash :: DSum HashAlgo Digest -- ^ Hash modulo of the derivation - , derivationOutputName :: outputName - -- ^ Name of the output + , derivationOutputOutput :: a + -- ^ Output (either a OutputName or StorePatH) } deriving (Eq, Generic, Ord, Show) data DerivationOutputError @@ -74,7 +74,7 @@ derivationOutputBuilder derivationOutputBuilder outputName DerivationOutput{..} = System.Nix.Hash.algoDigestBuilder derivationOutputHash <> Data.Text.Lazy.Builder.singleton '!' - <> Data.Text.Lazy.Builder.fromText (outputName derivationOutputName) + <> Data.Text.Lazy.Builder.fromText (outputName derivationOutputOutput) -- | Build realisation context -- diff --git a/hnix-store-json/tests/JSONSpec.hs b/hnix-store-json/tests/JSONSpec.hs index d5e0eac..df26ae4 100644 --- a/hnix-store-json/tests/JSONSpec.hs +++ b/hnix-store-json/tests/JSONSpec.hs @@ -38,7 +38,7 @@ sampleDerivationOutput = DerivationOutput $ System.Nix.Hash.mkNamedDigest "sha256" "1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0" - , derivationOutputName = + , derivationOutputOutput = forceRight $ System.Nix.OutputName.mkOutputName "foo" } From 69060eca7684d3f3da512c1b6f590fc0d83492c1 Mon Sep 17 00:00:00 2001 From: sorki Date: Wed, 6 Dec 2023 18:42:06 +0100 Subject: [PATCH 083/104] docs/contributors: add andreabedini --- docs/01-Contributors.org | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/01-Contributors.org b/docs/01-Contributors.org index c3266f1..20d88bf 100644 --- a/docs/01-Contributors.org +++ b/docs/01-Contributors.org @@ -30,3 +30,4 @@ in order of appearance: + Vaibhav Sagar @vaibhavsagar + Ryan Trinkle @ryantrinkle + Travis Whitaker @TravisWhitaker ++ Andrea Bedini @andreabedini From 0323bf06a599ca7d06cbd62ab123fcb68b60faef Mon Sep 17 00:00:00 2001 From: sorki Date: Wed, 6 Dec 2023 18:45:29 +0100 Subject: [PATCH 084/104] drop dependent-sum-template source-repository-package, add >= 0.2.0.1 lower bound --- cabal.project | 6 ------ hnix-store-core/hnix-store-core.cabal | 2 +- hnix-store-remote/hnix-store-remote.cabal | 2 +- 3 files changed, 2 insertions(+), 8 deletions(-) diff --git a/cabal.project b/cabal.project index bec4b58..6c26f75 100644 --- a/cabal.project +++ b/cabal.project @@ -22,9 +22,3 @@ package hnix-store-nar package hnix-store-remote flags: +build-derivation +build-readme +io-testsuite - --- until https://github.com/obsidiansystems/dependent-sum-template/pull/7 -source-repository-package - type: git - location: https://github.com/ncfavier/dependent-sum-template/ - tag: 6614029b47ec3957c871b2bbec91fe79f230cf9e diff --git a/hnix-store-core/hnix-store-core.cabal b/hnix-store-core/hnix-store-core.cabal index 3b35b44..c5caefd 100644 --- a/hnix-store-core/hnix-store-core.cabal +++ b/hnix-store-core/hnix-store-core.cabal @@ -82,7 +82,7 @@ library , crypton , data-default-class , dependent-sum > 0.7 - , dependent-sum-template > 0.1.1 && < 0.3 + , dependent-sum-template >= 0.2.0.1 && < 0.3 , filepath , hashable -- Required for crypton low-level type convertion diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index f3fd7c3..7327e6b 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -119,7 +119,7 @@ library , crypton , data-default-class , dependent-sum > 0.7 - , dependent-sum-template > 0.1.1 && < 0.3 + , dependent-sum-template >= 0.2.0.1 && < 0.3 , dlist >= 1.0 , generic-arbitrary < 1.1 , hashable From c8d97899e7eef61bd29b327df0ceb04fa12440b7 Mon Sep 17 00:00:00 2001 From: sorki Date: Wed, 6 Dec 2023 18:47:54 +0100 Subject: [PATCH 085/104] overlay.nix: dependent-sum-template 0.2.0.1 --- overlay.nix | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/overlay.nix b/overlay.nix index 75d7a34..0c2b460 100644 --- a/overlay.nix +++ b/overlay.nix @@ -23,17 +23,12 @@ in sha256 = "sha256-AnjaUzSlsLi3lIURrEfs92Jo5FzX49RyNdfDSfFV3Kk="; } {}; - # srk 2023-11-19: default in unstable is 0.1.1.1 which - # fails to compile test on ghc8107 - # but for for ghc963 we hit - # https://github.com/obsidiansystems/dependent-sum-template/issues/10 - # so we use 0.1.1.1 for ghc963 and 0.2.0.0 for the rest - # - some weird interaction in unstable as this builds - # with cabal and 0.2.0.0 - dependent-sum-template = - if compiler == "ghc8107" || compiler == "ghc902" || compiler == "ghc928" - then hsuper.dependent-sum-template_0_2_0_0 - else hsuper.dependent-sum-template; + # srk 2023-12-06: until in unstable + dependent-sum-template = hself.callHackageDirect + { pkg = "dependent-sum-template"; + ver = "0.2.0.1"; + sha256 = "sha256-quwgFuEBrK96JZenJZcyfk/O0Gp+ukwKEpe1hMqDbIg="; + } {}; # srk 2023-11-19: wider unix bound via CPP # Required for ghc963 since linux-namespaces is pinned From bdce1a30352b7073f7109ae0bf256ae8fd09936a Mon Sep 17 00:00:00 2001 From: sorki Date: Wed, 6 Dec 2023 19:04:46 +0100 Subject: [PATCH 086/104] tests: enable TypeFamilies for Realisation --- hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs index d5b6ab3..509b26a 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs @@ -1,3 +1,5 @@ +-- due to Illegal equational constraint Test.QuickCheck.Arbitrary.Generic.TypesDiffer +{-# LANGUAGE TypeFamilies #-} -- due to recent generic-arbitrary {-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} {-# OPTIONS_GHC -Wno-orphans #-} From aa94d3c3da8f435b17364e67088481ce796e85af Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 07:08:54 +0100 Subject: [PATCH 087/104] remote: separate (Client|Server)Handshake(Input|Output) types --- .../src/System/Nix/Store/Remote/Client.hs | 41 ++++++++------- .../src/System/Nix/Store/Remote/Server.hs | 50 ++++++++++--------- .../Nix/Store/Remote/Types/Handshake.hs | 38 ++++++++++---- 3 files changed, 79 insertions(+), 50 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 9a102b9..468406e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -30,7 +30,7 @@ import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, storeRequest, text, trustedFlag, workerMagic) -import System.Nix.Store.Remote.Types.Handshake (Handshake(..)) +import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeInput(..), ClientHandshakeOutput(..)) import System.Nix.Store.Remote.Types.Logger (Logger) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) @@ -177,16 +177,23 @@ runStoreSocket -> Run m a runStoreSocket preStoreConfig code = runRemoteStoreT preStoreConfig $ do - Handshake{..} <- greet + ClientHandshakeOutput{..} + <- greet + ClientHandshakeInput + { clientHandshakeInputOurVersion = ourProtoVersion + } + mapStoreConfig - (preStoreConfigToStoreConfig handshakeProtoVersion) + (preStoreConfigToStoreConfig + clientHandshakeOutputLeastCommonVerison) code where greet :: MonadIO m - => RemoteStoreT PreStoreConfig m Handshake - greet = do + => ClientHandshakeInput + -> RemoteStoreT PreStoreConfig m ClientHandshakeOutput + greet ClientHandshakeInput{..} = do sockPutS (mapErrorS @@ -210,19 +217,19 @@ runStoreSocket preStoreConfig code = when (daemonVersion < ProtoVersion 1 10) $ throwError RemoteStoreError_ClientVersionTooOld - sockPutS protoVersion ourProtoVersion + sockPutS protoVersion clientHandshakeInputOurVersion - let minimumCommonVersion = min daemonVersion ourProtoVersion + let leastCommonVersion = min daemonVersion ourProtoVersion - when (minimumCommonVersion >= ProtoVersion 1 14) + when (leastCommonVersion >= ProtoVersion 1 14) $ sockPutS int (0 :: Int) -- affinity, obsolete - when (minimumCommonVersion >= ProtoVersion 1 11) $ do + when (leastCommonVersion >= ProtoVersion 1 11) $ do sockPutS (mapErrorS RemoteStoreError_SerializerPut bool) False -- reserveSpace, obsolete - daemonNixVersion <- if minimumCommonVersion >= ProtoVersion 1 33 + daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33 then do -- If we were buffering I/O, we would flush the output here. txtVer <- @@ -233,19 +240,19 @@ runStoreSocket preStoreConfig code = pure $ Just txtVer else pure Nothing - remoteTrustsUs <- if minimumCommonVersion >= ProtoVersion 1 35 + remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35 then do sockGetS $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag else pure Nothing mapStoreConfig - (preStoreConfigToStoreConfig minimumCommonVersion) + (preStoreConfigToStoreConfig leastCommonVersion) processOutput - pure Handshake - { handshakeNixVersion = daemonNixVersion - , handshakeTrust = remoteTrustsUs - , handshakeProtoVersion = minimumCommonVersion - , handshakeRemoteProtoVersion = daemonVersion + pure ClientHandshakeOutput + { clientHandshakeOutputNixVersion = daemonNixVersion + , clientHandshakeOutputTrust = remoteTrustsUs + , clientHandshakeOutputLeastCommonVerison = leastCommonVersion + , clientHandshakeOutputServerVersion = daemonVersion } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs index 462be1f..41cd473 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs @@ -27,7 +27,7 @@ import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVer import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..)) import System.Nix.Store.Remote.MonadStore (WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT, mapStoreConfig) -import System.Nix.Store.Remote.Types.Handshake (Handshake(..)) +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(..)) @@ -79,28 +79,26 @@ processConnection -> PreStoreConfig -> m () processConnection workerHelper preStoreConfig = do - let handshake = Handshake - { handshakeNixVersion = Just "nixVersion (hnix-store-remote)" - , handshakeTrust = Nothing - -- TODO: doesn't make sense for server - , handshakeProtoVersion = ourProtoVersion - -- TODO: doesn't make sense for server - , handshakeRemoteProtoVersion = ourProtoVersion - } - ~() <- void $ runRemoteStoreT preStoreConfig $ do - minimumCommonVersion <- greet handshake + ServerHandshakeOutput{..} + <- greet + ServerHandshakeInput + { serverHandshakeInputNixVersion = "nixVersion (hnix-store-remote)" + , serverHandshakeInputOurVersion= ourProtoVersion + , serverHandshakeInputTrust = Nothing + } mapStoreConfig - (preStoreConfigToStoreConfig minimumCommonVersion) + (preStoreConfigToStoreConfig + serverHandshakeOutputLeastCommonVersion) $ do tunnelLogger <- liftIO $ newTunnelLogger -- Send startup error messages to the client. 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). --authHook(*store); stopWork tunnelLogger @@ -124,9 +122,9 @@ processConnection workerHelper preStoreConfig = do -- Exchange the greeting. greet :: MonadIO m - => Handshake - -> RemoteStoreT PreStoreConfig m ProtoVersion - greet Handshake{..} = do + => ServerHandshakeInput + -> RemoteStoreT PreStoreConfig m ServerHandshakeOutput + greet ServerHandshakeInput{..} = do magic <- sockGetS $ mapErrorS @@ -135,7 +133,9 @@ processConnection workerHelper preStoreConfig = do liftIO $ print ("magic" :: Text, magic) when (magic /= WorkerMagic_One) - $ throwError $ RemoteStoreError_WorkerException WorkerException_ProtocolMismatch + $ throwError + $ RemoteStoreError_WorkerException + WorkerException_ProtocolMismatch sockPutS (mapErrorS @@ -144,13 +144,13 @@ processConnection workerHelper preStoreConfig = do ) WorkerMagic_Two - sockPutS protoVersion ourProtoVersion + sockPutS protoVersion serverHandshakeInputOurVersion clientVersion <- sockGetS protoVersion - let minimumCommonVersion = min clientVersion ourProtoVersion + let leastCommonVersion = min clientVersion ourProtoVersion - liftIO $ print ("Versions client, min" :: Text, clientVersion, minimumCommonVersion) + liftIO $ print ("Versions client, min" :: Text, clientVersion, leastCommonVersion) when (clientVersion < ProtoVersion 1 10) $ throwError @@ -174,8 +174,7 @@ processConnection workerHelper preStoreConfig = do RemoteStoreError_SerializerPut text ) - -- TODO - (maybe undefined id handshakeNixVersion) + serverHandshakeInputNixVersion when (clientVersion >= ProtoVersion 1 35) $ do sockPutS @@ -183,9 +182,12 @@ processConnection workerHelper preStoreConfig = do RemoteStoreError_SerializerHandshake trustedFlag ) - handshakeTrust + serverHandshakeInputTrust - pure minimumCommonVersion + pure ServerHandshakeOutput + { serverHandshakeOutputLeastCommonVersion = leastCommonVersion + , serverHandshakeOutputClientVersion = clientVersion + } simpleOp :: ( MonadIO m diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs index 81f62cd..3f3fa90 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs @@ -1,5 +1,8 @@ module System.Nix.Store.Remote.Types.Handshake - ( Handshake(..) + ( ClientHandshakeInput(..) + , ClientHandshakeOutput(..) + , ServerHandshakeInput(..) + , ServerHandshakeOutput(..) ) where import Data.Text (Text) @@ -7,11 +10,28 @@ import GHC.Generics (Generic) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) import System.Nix.Store.Remote.Types.TrustedFlag (TrustedFlag) --- | Data for initial protocol handshake -data Handshake = Handshake - { handshakeNixVersion :: Maybe Text -- ^ Textual version, since 1.33 - , handshakeTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us - , handshakeProtoVersion :: ProtoVersion -- ^ Minimum protocol supported by both sides - , handshakeRemoteProtoVersion :: ProtoVersion -- ^ Protocol supported by remote side - } - deriving (Eq, Generic, Ord, Show) +-- | Data sent by the client during initial protocol handshake +data ClientHandshakeInput = ClientHandshakeInput + { clientHandshakeInputOurVersion :: ProtoVersion -- ^ Our protocol version (that we advertise to the server) + } deriving (Eq, Generic, Ord, Show) + +-- | Data received by the client via initial protocol handshake +data ClientHandshakeOutput = ClientHandshakeOutput + { clientHandshakeOutputNixVersion :: Maybe Text -- ^ Textual version, since 1.33 + , clientHandshakeOutputTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us + , clientHandshakeOutputLeastCommonVerison :: ProtoVersion -- ^ Minimum protocol version supported by both sides + , clientHandshakeOutputServerVersion :: ProtoVersion -- ^ Protocol version supported by the server + } deriving (Eq, Generic, Ord, Show) + +-- | Data sent by the server during initial protocol handshake +data ServerHandshakeInput = ServerHandshakeInput + { serverHandshakeInputNixVersion :: Text -- ^ Textual version, since 1.33 + , serverHandshakeInputOurVersion :: ProtoVersion -- ^ Our protocol version (that we advertise to the client) + , serverHandshakeInputTrust :: Maybe TrustedFlag -- ^ Whether client should trusts us + } deriving (Eq, Generic, Ord, Show) + +-- | Data received by the server during initial protocol handshake +data ServerHandshakeOutput = ServerHandshakeOutput + { serverHandshakeOutputLeastCommonVersion :: ProtoVersion -- ^ Minimum protocol version supported by both sides + , serverHandshakeOutputClientVersion :: ProtoVersion -- ^ Protocol version supported by the client + } deriving (Eq, Generic, Ord, Show) From 7dc5c596aac604a3c3da598d3fc2f3cccb128755 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 07:12:27 +0100 Subject: [PATCH 088/104] tests: add/move Test.Hspec.Nix.forceRight from json --- hnix-store-core/tests/Fingerprint.hs | 2 +- hnix-store-json/tests/JSONSpec.hs | 10 +--------- hnix-store-tests/src/Test/Hspec/Nix.hs | 11 ++++++++++- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/hnix-store-core/tests/Fingerprint.hs b/hnix-store-core/tests/Fingerprint.hs index 8874ffc..77c890d 100644 --- a/hnix-store-core/tests/Fingerprint.hs +++ b/hnix-store-core/tests/Fingerprint.hs @@ -69,5 +69,5 @@ forceDecodeB64Pubkey b64EncodedPubkey = let forceRight :: Either a b -> b forceRight = \case Right x -> x - _ -> error "fromRight failed" + _ -> error "forceRight failed" diff --git a/hnix-store-json/tests/JSONSpec.hs b/hnix-store-json/tests/JSONSpec.hs index df26ae4..6aad8a8 100644 --- a/hnix-store-json/tests/JSONSpec.hs +++ b/hnix-store-json/tests/JSONSpec.hs @@ -5,7 +5,7 @@ import Data.Aeson (ToJSON, FromJSON, decode, encode) import Data.Default.Class (Default(def)) import Test.Hspec (Expectation, Spec, describe, it, shouldBe) import Test.Hspec.QuickCheck (prop) -import Test.Hspec.Nix (roundtrips) +import Test.Hspec.Nix (forceRight, roundtrips) import System.Nix.Arbitrary () import System.Nix.JSON () @@ -99,11 +99,3 @@ spec = do it "sampleRealisation1 matches preimage" $ encode sampleRealisation1 `shouldBe` "{\"outPath\":\"5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv\",\"signatures\":[\"SMjnB3mPgXYjXacU+xN24BdzXlAgGAuFnYwPddU3bhjfHBeQus/OimdIPMgR/JMKFPHXORrk7pbjv68vecTEBA==\",\"fW3iEMfyx6IZzGNswD54BjclfkXiYzh0xRXddrXfJ1rp1l8p1xTi9/0g2EibbwLFb6p83cwIJv5KtTGksC54CQ==\"],\"dependentRealisations\":{\"sha256:1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0!foo\":\"9472ijanf79nlkb5n1yh57s7867p1930-testFixed\"}}" - -forceRight - :: Show a - => Either a b - -> b -forceRight = \case - Right x -> x - Left e -> error $ "fromRight failed: " ++ show e diff --git a/hnix-store-tests/src/Test/Hspec/Nix.hs b/hnix-store-tests/src/Test/Hspec/Nix.hs index 01416d9..814ca8f 100644 --- a/hnix-store-tests/src/Test/Hspec/Nix.hs +++ b/hnix-store-tests/src/Test/Hspec/Nix.hs @@ -1,5 +1,6 @@ module Test.Hspec.Nix - ( roundtrips + ( forceRight + , roundtrips ) where import Test.Hspec (Expectation, shouldBe) @@ -18,3 +19,11 @@ roundtrips -> Expectation roundtrips encode decode x = decode (encode x) `shouldBe` pure x + +forceRight + :: Show a + => Either a b + -> b +forceRight = \case + Right x -> x + Left e -> error $ "forceRight failed: " ++ show e From 428a61a538fe24d889e62f6a5213df0511f1b18a Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 07:24:22 +0100 Subject: [PATCH 089/104] remote: split runStoreSocket, doReq into Remote.Client.Core --- hnix-store-remote/hnix-store-remote.cabal | 1 + .../src/System/Nix/Store/Remote/Client.hs | 170 ++--------------- .../System/Nix/Store/Remote/Client/Core.hs | 174 ++++++++++++++++++ 3 files changed, 187 insertions(+), 158 deletions(-) create mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 7327e6b..2eca734 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -78,6 +78,7 @@ library , System.Nix.Store.Remote , System.Nix.Store.Remote.Arbitrary , System.Nix.Store.Remote.Client + , System.Nix.Store.Remote.Client.Core , System.Nix.Store.Remote.Logger , System.Nix.Store.Remote.MonadStore , System.Nix.Store.Remote.Serialize diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index 468406e..ff99c3a 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -1,48 +1,38 @@ module System.Nix.Store.Remote.Client - ( Run - , simpleOp + ( simpleOp , simpleOpArgs , runOp , runOpArgs , runOpArgsIO - , runStoreSocket - , ourProtoVersion - , doReq , addToStore , buildDerivation , isValidPath + , module System.Nix.Store.Remote.Client.Core ) where -import Control.Monad (unless, when) +import Control.Monad (when) import Control.Monad.Except (throwError) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.DList (DList) +import Control.Monad.IO.Class (liftIO) import Data.Serialize.Put (Put, runPut) -import Data.Some (Some(Some)) - -import qualified Data.ByteString -import qualified Network.Socket.ByteString +import Data.Some (Some) +import Data.Text (Text) +import System.Nix.Build (BuildMode, BuildResult) +import System.Nix.Derivation (Derivation) import System.Nix.Hash (HashAlgo(..)) import System.Nix.Nar (NarSource) import System.Nix.StorePath (StorePath, StorePathName) import System.Nix.Store.Remote.Logger (processOutput) import System.Nix.Store.Remote.MonadStore import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) -import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, storeRequest, text, trustedFlag, workerMagic) -import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeInput(..), ClientHandshakeOutput(..)) -import System.Nix.Store.Remote.Types.Logger (Logger) -import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) -import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) +import System.Nix.Store.Remote.Serializer (bool, enum, mapErrorS) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) -import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..)) -import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) +import System.Nix.Store.Remote.Client.Core import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) -import Data.Text -import System.Nix.Build -import System.Nix.Derivation (Derivation) +import qualified Data.ByteString +import qualified Network.Socket.ByteString simpleOp :: MonadRemoteStore m @@ -93,47 +83,6 @@ runOpArgsIO op encoder = do processOutput --- | Perform @StoreRequest@ -doReq - :: forall m a - . ( MonadIO m - , MonadRemoteStore m - , StoreReply a - , Show a - ) - => StoreRequest a - -> m a -doReq = \case - x -> do - sockPutS - (mapErrorS - RemoteStoreError_SerializerRequest - storeRequest - ) - (Some x) - - case x of - AddToStore {} -> do - - ms <- takeNarSource - case ms of - Just (stream :: NarSource IO) -> do - soc <- getStoreSocket - liftIO - $ stream - $ Network.Socket.ByteString.sendAll soc - Nothing -> - throwError - RemoteStoreError_NoNarSourceProvided - - _ -> pure () - - processOutput - sockGetS - (mapErrorS RemoteStoreError_SerializerReply - $ getReplyS @a - ) - -- | Add `NarSource` to the store addToStore :: MonadRemoteStore m @@ -159,100 +108,5 @@ buildDerivation -> m BuildResult buildDerivation a b c = doReq (BuildDerivation a b c) ---isValidPath :: MonadIO m => StorePath -> RemoteStoreT StoreConfig m Bool ---isValidPath = doReq . IsValidPath - --- TOOD: want this, but Logger.processOutput is fixed to RemoteStoreT r m isValidPath :: MonadRemoteStore m => StorePath -> m Bool isValidPath = doReq . IsValidPath - -type Run m a = m (Either RemoteStoreError a, DList Logger) - -runStoreSocket - :: ( Monad m - , MonadIO m - ) - => PreStoreConfig - -> RemoteStoreT StoreConfig m a - -> Run m a -runStoreSocket preStoreConfig code = - runRemoteStoreT preStoreConfig $ do - ClientHandshakeOutput{..} - <- greet - ClientHandshakeInput - { clientHandshakeInputOurVersion = ourProtoVersion - } - - mapStoreConfig - (preStoreConfigToStoreConfig - clientHandshakeOutputLeastCommonVerison) - code - - where - greet - :: MonadIO m - => ClientHandshakeInput - -> RemoteStoreT PreStoreConfig m ClientHandshakeOutput - greet ClientHandshakeInput{..} = do - - sockPutS - (mapErrorS - RemoteStoreError_SerializerHandshake - workerMagic - ) - WorkerMagic_One - - magic <- - sockGetS - $ mapErrorS - RemoteStoreError_SerializerHandshake - workerMagic - - unless - (magic == WorkerMagic_Two) - $ throwError RemoteStoreError_WorkerMagic2Mismatch - - daemonVersion <- sockGetS protoVersion - - when (daemonVersion < ProtoVersion 1 10) - $ throwError RemoteStoreError_ClientVersionTooOld - - sockPutS protoVersion clientHandshakeInputOurVersion - - let leastCommonVersion = min daemonVersion ourProtoVersion - - when (leastCommonVersion >= ProtoVersion 1 14) - $ sockPutS int (0 :: Int) -- affinity, obsolete - - when (leastCommonVersion >= ProtoVersion 1 11) $ do - sockPutS - (mapErrorS RemoteStoreError_SerializerPut bool) - False -- reserveSpace, obsolete - - daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33 - then do - -- If we were buffering I/O, we would flush the output here. - txtVer <- - sockGetS - $ mapErrorS - RemoteStoreError_SerializerGet - text - pure $ Just txtVer - else pure Nothing - - remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35 - then do - sockGetS - $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag - else pure Nothing - - mapStoreConfig - (preStoreConfigToStoreConfig leastCommonVersion) - processOutput - - pure ClientHandshakeOutput - { clientHandshakeOutputNixVersion = daemonNixVersion - , clientHandshakeOutputTrust = remoteTrustsUs - , clientHandshakeOutputLeastCommonVerison = leastCommonVersion - , clientHandshakeOutputServerVersion = daemonVersion - } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs new file mode 100644 index 0000000..8837c06 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs @@ -0,0 +1,174 @@ +module System.Nix.Store.Remote.Client.Core + ( Run + , runStoreSocket + , doReq + ) where + +import Control.Monad (unless, when) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.DList (DList) +import Data.Some (Some(Some)) +import System.Nix.Nar (NarSource) +import System.Nix.Store.Remote.Logger (processOutput) +import System.Nix.Store.Remote.MonadStore + ( MonadRemoteStore + , RemoteStoreError(..) + , RemoteStoreT + , runRemoteStoreT + , mapStoreConfig + , takeNarSource + , getStoreSocket + ) +import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) +import System.Nix.Store.Remote.Serializer + ( bool + , int + , mapErrorS + , protoVersion + , storeRequest + , text + , trustedFlag + , workerMagic + ) +import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeInput(..), ClientHandshakeOutput(..)) +import System.Nix.Store.Remote.Types.Logger (Logger) +import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion) +import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig) +import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) +import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..)) +import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..)) + +import qualified Network.Socket.ByteString + +type Run m a = m (Either RemoteStoreError a, DList Logger) + +-- | Perform @StoreRequest@ +doReq + :: forall m a + . ( MonadIO m + , MonadRemoteStore m + , StoreReply a + , Show a + ) + => StoreRequest a + -> m a +doReq = \case + x -> do + sockPutS + (mapErrorS + RemoteStoreError_SerializerRequest + storeRequest + ) + (Some x) + + case x of + AddToStore {} -> do + + ms <- takeNarSource + case ms of + Just (stream :: NarSource IO) -> do + soc <- getStoreSocket + liftIO + $ stream + $ Network.Socket.ByteString.sendAll soc + Nothing -> + throwError + RemoteStoreError_NoNarSourceProvided + + _ -> pure () + + processOutput + sockGetS + (mapErrorS RemoteStoreError_SerializerReply + $ getReplyS @a + ) + +runStoreSocket + :: ( Monad m + , MonadIO m + ) + => PreStoreConfig + -> RemoteStoreT StoreConfig m a + -> Run m a +runStoreSocket preStoreConfig code = + runRemoteStoreT preStoreConfig $ do + ClientHandshakeOutput{..} + <- greet + ClientHandshakeInput + { clientHandshakeInputOurVersion = ourProtoVersion + } + + mapStoreConfig + (preStoreConfigToStoreConfig + clientHandshakeOutputLeastCommonVerison) + code + + where + greet + :: MonadIO m + => ClientHandshakeInput + -> RemoteStoreT PreStoreConfig m ClientHandshakeOutput + greet ClientHandshakeInput{..} = do + + sockPutS + (mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + ) + WorkerMagic_One + + magic <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerHandshake + workerMagic + + unless + (magic == WorkerMagic_Two) + $ throwError RemoteStoreError_WorkerMagic2Mismatch + + daemonVersion <- sockGetS protoVersion + + when (daemonVersion < ProtoVersion 1 10) + $ throwError RemoteStoreError_ClientVersionTooOld + + sockPutS protoVersion clientHandshakeInputOurVersion + + let leastCommonVersion = min daemonVersion ourProtoVersion + + when (leastCommonVersion >= ProtoVersion 1 14) + $ sockPutS int (0 :: Int) -- affinity, obsolete + + when (leastCommonVersion >= ProtoVersion 1 11) $ do + sockPutS + (mapErrorS RemoteStoreError_SerializerPut bool) + False -- reserveSpace, obsolete + + daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33 + then do + -- If we were buffering I/O, we would flush the output here. + txtVer <- + sockGetS + $ mapErrorS + RemoteStoreError_SerializerGet + text + pure $ Just txtVer + else pure Nothing + + remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35 + then do + sockGetS + $ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag + else pure Nothing + + mapStoreConfig + (preStoreConfigToStoreConfig leastCommonVersion) + processOutput + + pure ClientHandshakeOutput + { clientHandshakeOutputNixVersion = daemonNixVersion + , clientHandshakeOutputTrust = remoteTrustsUs + , clientHandshakeOutputLeastCommonVerison = leastCommonVersion + , clientHandshakeOutputServerVersion = daemonVersion + } From 7bdbab9c532503283f6503b05eed6e2a80d2c384 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 08:02:21 +0100 Subject: [PATCH 090/104] remote: move enum tests to EnumSpec --- hnix-store-remote/hnix-store-remote.cabal | 2 + .../src/System/Nix/Store/Remote/Serializer.hs | 13 +- hnix-store-remote/tests/EnumSpec.hs | 136 ++++++++++++++++++ hnix-store-remote/tests/NixSerializerSpec.hs | 16 +-- hnix-store-remote/tests/SerializeSpec.hs | 77 +--------- 5 files changed, 147 insertions(+), 97 deletions(-) create mode 100644 hnix-store-remote/tests/EnumSpec.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 2eca734..8f010ff 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -170,6 +170,7 @@ test-suite remote ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N" other-modules: Data.SerializerSpec + EnumSpec NixSerializerSpec SerializeSpec build-tool-depends: @@ -179,6 +180,7 @@ test-suite remote , hnix-store-core , hnix-store-remote , hnix-store-tests + , bytestring , cereal , crypton , some > 1.0.5 && < 2 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index a9fbf28..dc0cc25 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -68,6 +68,7 @@ module System.Nix.Store.Remote.Serializer , LoggerSError(..) , activityID , maybeActivity + , activity , activityResult , field , trace @@ -886,12 +887,12 @@ maybeActivity = Serializer Nothing -> putS (int @Int) 0 Just act -> putS activity act } - where - activity :: NixSerializer r LoggerSError Activity - activity = Serializer - { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100)) - , putS = putS int . (+100) . fromEnum - } + +activity :: NixSerializer r LoggerSError Activity +activity = Serializer + { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100)) + , putS = putS int . (+100) . fromEnum + } activityID :: NixSerializer r LoggerSError ActivityID activityID = mapIsoSerializer ActivityID unActivityID int diff --git a/hnix-store-remote/tests/EnumSpec.hs b/hnix-store-remote/tests/EnumSpec.hs new file mode 100644 index 0000000..1c28c1c --- /dev/null +++ b/hnix-store-remote/tests/EnumSpec.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} + +module EnumSpec (spec) where + +import Test.Hspec (SpecWith, Spec, describe, it, shouldBe) + +import Data.ByteString (ByteString) +import Data.Word (Word64) +import System.Nix.Build (BuildMode(..), BuildStatus(..)) +import System.Nix.Store.Remote.Serializer + ( activity + , activityResult + , enum + , int + , loggerOpCode + , runP + , LoggerSError + , NixSerializer + , SError + ) +import System.Nix.Store.Remote.Types + +spec :: Spec +spec = do + let + itE + :: ( Enum a + , Show a + ) + => String + -> a + -> Word64 + -> SpecWith () + itE name constr value = + it name + $ ((runP enum () constr) :: Either SError ByteString) + `shouldBe` + (runP (int @Word64) () value) + + itE' + :: Show a + => NixSerializer () LoggerSError a + -> String + -> a + -> Word64 + -> SpecWith () + itE' s name constr value = + it name + $ ((runP s () constr) :: Either LoggerSError ByteString) + `shouldBe` + (runP (int @Word64) () (value)) + + describe "Enums" $ do + describe "BuildMode enum order matches Nix" $ do + itE "Normal" BuildMode_Normal 0 + itE "Repair" BuildMode_Repair 1 + itE "Check" BuildMode_Check 2 + + describe "BuildStatus enum order matches Nix" $ do + itE "Built" BuildStatus_Built 0 + itE "Substituted" BuildStatus_Substituted 1 + itE "AlreadyValid" BuildStatus_AlreadyValid 2 + itE "PermanentFailure" BuildStatus_PermanentFailure 3 + itE "InputRejected" BuildStatus_InputRejected 4 + itE "OutputRejected" BuildStatus_OutputRejected 5 + itE "TransientFailure" BuildStatus_TransientFailure 6 + itE "CachedFailure" BuildStatus_CachedFailure 7 + itE "TimedOut" BuildStatus_TimedOut 8 + itE "MiscFailure" BuildStatus_MiscFailure 9 + itE "DependencyFailed" BuildStatus_DependencyFailed 10 + itE "LogLimitExceeded" BuildStatus_LogLimitExceeded 11 + itE "NotDeterministic" BuildStatus_NotDeterministic 12 + itE "ResolvesToAlreadyValid" BuildStatus_ResolvesToAlreadyValid 13 + itE "NoSubstituters" BuildStatus_NoSubstituters 14 + + describe "GCAction enum order matches Nix" $ do + itE "ReturnLive" GCAction_ReturnLive 0 + itE "ReturnDead" GCAction_ReturnDead 1 + itE "DeleteDead" GCAction_DeleteDead 2 + itE "DeleteSpecific" GCAction_DeleteSpecific 3 + + describe "Logger" $ do + let itA = itE' activity + describe "Activity enum order matches Nix" $ do + itA "CopyPath" Activity_CopyPath 100 + itA "FileTransfer" Activity_FileTransfer 101 + itA "Realise" Activity_Realise 102 + itA "CopyPaths" Activity_CopyPaths 103 + itA "Builds" Activity_Builds 104 + itA "Build" Activity_Build 105 + itA "OptimiseStore" Activity_OptimiseStore 106 + itA "VerifyPaths" Activity_VerifyPaths 107 + itA "Substitute" Activity_Substitute 108 + itA "QueryPathInfo" Activity_QueryPathInfo 109 + itA "PostBuildHook" Activity_PostBuildHook 110 + itA "BuildWaiting" Activity_BuildWaiting 111 + + let itR = itE' activityResult + describe "ActivityResult enum order matches Nix" $ do + itR "FileLinked" ActivityResult_FileLinked 100 + itR "BuildLogLine" ActivityResult_BuildLogLine 101 + itR "UnstrustedPath" ActivityResult_UnstrustedPath 102 + itR "CorruptedPath" ActivityResult_CorruptedPath 103 + itR "SetPhase" ActivityResult_SetPhase 104 + itR "Progress" ActivityResult_Progress 105 + itR "SetExpected" ActivityResult_SetExpected 106 + itR "PostBuildLogLine" ActivityResult_PostBuildLogLine 107 + + + let itL = itE' loggerOpCode + describe "LoggerOpCode matches Nix" $ do + itL "Next" LoggerOpCode_Next 0x6f6c6d67 + itL "Read" LoggerOpCode_Read 0x64617461 + itL "Write" LoggerOpCode_Write 0x64617416 + itL "Last" LoggerOpCode_Last 0x616c7473 + itL "Error" LoggerOpCode_Error 0x63787470 + itL "StartActivity" LoggerOpCode_StartActivity 0x53545254 + itL "StopActivity" LoggerOpCode_StopActivity 0x53544f50 + itL "Result" LoggerOpCode_Result 0x52534c54 + + describe "Verbosity enum order matches Nix" $ do + itE "Error" Verbosity_Error 0 + itE "Warn" Verbosity_Warn 1 + itE "Notice" Verbosity_Notice 2 + itE "Info" Verbosity_Info 3 + itE "Talkative" Verbosity_Talkative 4 + itE "Chatty" Verbosity_Chatty 5 + itE "Debug" Verbosity_Debug 6 + itE "Vomit" Verbosity_Vomit 7 + + describe "WorkerOp enum order matches Nix" $ do + itE "IsValidPath" WorkerOp_IsValidPath 1 + itE "BuildPathsWithResults" WorkerOp_BuildPathsWithResults 46 + + + diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index fbdcaa3..219d713 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -5,8 +5,7 @@ module NixSerializerSpec (spec) where import Crypto.Hash (MD5, SHA1, SHA256, SHA512) import Data.Some (Some(Some)) import Data.Time (UTCTime) -import Data.Word (Word64) -import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe) +import Test.Hspec (Expectation, Spec, describe, parallel, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, arbitrary, forAll, suchThat) @@ -20,7 +19,6 @@ 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.StoreRequest (StoreRequest(..)) -import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp(..)) -- | Test for roundtrip using @NixSerializer@ roundtripSReader @@ -138,18 +136,6 @@ spec = parallel $ do forAll (arbitrary `suchThat` errorInfoIf (protoVersion_minor pv >= 26)) $ roundtripSReader logger pv - describe "Enums" $ do - let it' name constr value = - it name - $ (runP enum () constr) - `shouldBe` - (runP (int @Word64) () value) - - describe "WorkerOp enum order matches Nix" $ do - it' "IsValidPath" WorkerOp_IsValidPath 1 - it' "BuildPathsWithResults" WorkerOp_BuildPathsWithResults 46 - - describe "Handshake" $ do prop "WorkerMagic" $ roundtripS workerMagic prop "TrustedFlag" $ roundtripS trustedFlag diff --git a/hnix-store-remote/tests/SerializeSpec.hs b/hnix-store-remote/tests/SerializeSpec.hs index c26313b..1855f47 100644 --- a/hnix-store-remote/tests/SerializeSpec.hs +++ b/hnix-store-remote/tests/SerializeSpec.hs @@ -6,7 +6,7 @@ import Data.Serialize (Serialize(..)) import Data.Serialize.Get (Get, runGet) import Data.Serialize.Put (Putter, runPut) import Data.Text (Text) -import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe) +import Test.Hspec (Expectation, Spec, describe, parallel) import Test.Hspec.QuickCheck (prop) import Test.Hspec.Nix (roundtrips) @@ -95,78 +95,3 @@ spec = parallel $ do prop "ErrorInfo" $ roundtripS @ErrorInfo prop "LoggerOpCode" $ roundtripS @LoggerOpCode prop "Verbosity" $ roundtripS @Verbosity - - describe "Enums" $ do - let it' name constr value = it name $ runPut (put constr) `shouldBe` runPut (putInt @Int value) - describe "BuildMode enum order matches Nix" $ do - it' "Normal" BuildMode_Normal 0 - it' "Repair" BuildMode_Repair 1 - it' "Check" BuildMode_Check 2 - - describe "BuildStatus enum order matches Nix" $ do - it' "Built" BuildStatus_Built 0 - it' "Substituted" BuildStatus_Substituted 1 - it' "AlreadyValid" BuildStatus_AlreadyValid 2 - it' "PermanentFailure" BuildStatus_PermanentFailure 3 - it' "InputRejected" BuildStatus_InputRejected 4 - it' "OutputRejected" BuildStatus_OutputRejected 5 - it' "TransientFailure" BuildStatus_TransientFailure 6 - it' "CachedFailure" BuildStatus_CachedFailure 7 - it' "TimedOut" BuildStatus_TimedOut 8 - it' "MiscFailure" BuildStatus_MiscFailure 9 - it' "DependencyFailed" BuildStatus_DependencyFailed 10 - it' "LogLimitExceeded" BuildStatus_LogLimitExceeded 11 - it' "NotDeterministic" BuildStatus_NotDeterministic 12 - it' "ResolvesToAlreadyValid" BuildStatus_ResolvesToAlreadyValid 13 - it' "NoSubstituters" BuildStatus_NoSubstituters 14 - - describe "GCAction enum order matches Nix" $ do - it' "ReturnLive" GCAction_ReturnLive 0 - it' "ReturnDead" GCAction_ReturnDead 1 - it' "DeleteDead" GCAction_DeleteDead 2 - it' "DeleteSpecific" GCAction_DeleteSpecific 3 - - describe "Logger" $ do - describe "Activity enum order matches Nix" $ do - it' "CopyPath" Activity_CopyPath 100 - it' "FileTransfer" Activity_FileTransfer 101 - it' "Realise" Activity_Realise 102 - it' "CopyPaths" Activity_CopyPaths 103 - it' "Builds" Activity_Builds 104 - it' "Build" Activity_Build 105 - it' "OptimiseStore" Activity_OptimiseStore 106 - it' "VerifyPaths" Activity_VerifyPaths 107 - it' "Substitute" Activity_Substitute 108 - it' "QueryPathInfo" Activity_QueryPathInfo 109 - it' "PostBuildHook" Activity_PostBuildHook 110 - it' "BuildWaiting" Activity_BuildWaiting 111 - - describe "ActivityResult enum order matches Nix" $ do - it' "FileLinked" ActivityResult_FileLinked 100 - it' "BuildLogLine" ActivityResult_BuildLogLine 101 - it' "UnstrustedPath" ActivityResult_UnstrustedPath 102 - it' "CorruptedPath" ActivityResult_CorruptedPath 103 - it' "SetPhase" ActivityResult_SetPhase 104 - it' "Progress" ActivityResult_Progress 105 - it' "SetExpected" ActivityResult_SetExpected 106 - it' "PostBuildLogLine" ActivityResult_PostBuildLogLine 107 - - describe "LoggerOpCode matches Nix" $ do - it' "Next" LoggerOpCode_Next 0x6f6c6d67 - it' "Read" LoggerOpCode_Read 0x64617461 - it' "Write" LoggerOpCode_Write 0x64617416 - it' "Last" LoggerOpCode_Last 0x616c7473 - it' "Error" LoggerOpCode_Error 0x63787470 - it' "StartActivity" LoggerOpCode_StartActivity 0x53545254 - it' "StopActivity" LoggerOpCode_StopActivity 0x53544f50 - it' "Result" LoggerOpCode_Result 0x52534c54 - - describe "Verbosity enum order matches Nix" $ do - it' "Error" Verbosity_Error 0 - it' "Warn" Verbosity_Warn 1 - it' "Notice" Verbosity_Notice 2 - it' "Info" Verbosity_Info 3 - it' "Talkative" Verbosity_Talkative 4 - it' "Chatty" Verbosity_Chatty 5 - it' "Debug" Verbosity_Debug 6 - it' "Vomit" Verbosity_Vomit 7 From a5dac6da5f5a18de588cd51211d0f1de96e5513e Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 08:25:38 +0100 Subject: [PATCH 091/104] remote: shuffle reply serializers, extend ReplySError --- .../src/System/Nix/Store/Remote/Serializer.hs | 191 ++++++++++-------- .../Nix/Store/Remote/Types/StoreReply.hs | 4 +- 2 files changed, 107 insertions(+), 88 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index dc0cc25..b3d3f79 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -44,10 +44,6 @@ module System.Nix.Store.Remote.Serializer , pathMetadata -- * OutputName , outputName - -- * Realisation - , derivationOutputTyped - , realisation - , realisationWithId -- * Signatures , signature , narSignature @@ -63,7 +59,6 @@ module System.Nix.Store.Remote.Serializer , derivedPath -- * Build , buildMode - , buildResult -- * Logger , LoggerSError(..) , activityID @@ -89,6 +84,12 @@ module System.Nix.Store.Remote.Serializer , storeRequest -- ** Reply , ReplySError(..) + -- *** Realisation + , derivationOutputTyped + , realisation + , realisationWithId + -- *** BuildResult + , buildResult ) where import Control.Monad.Except (MonadError, throwError, ) @@ -620,28 +621,6 @@ outputName = System.Nix.OutputName.unOutputName text --- * Realisation - -derivationOutputTyped :: NixSerializer r SError (System.Nix.Realisation.DerivationOutput OutputName) -derivationOutputTyped = - mapPrismSerializer - ( Data.Bifunctor.first SError_DerivationOutput - . System.Nix.Realisation.derivationOutputParser - System.Nix.OutputName.mkOutputName - ) - ( Data.Text.Lazy.toStrict - . Data.Text.Lazy.Builder.toLazyText - . System.Nix.Realisation.derivationOutputBuilder - System.Nix.OutputName.unOutputName - ) - text - -realisation :: NixSerializer r SError Realisation -realisation = json - -realisationWithId :: NixSerializer r SError (System.Nix.Realisation.DerivationOutput OutputName, Realisation) -realisationWithId = json - -- * Signatures signature @@ -804,64 +783,6 @@ derivedPath = Serializer buildMode :: NixSerializer r SError BuildMode buildMode = enum -buildResult - :: ( HasProtoVersion r - , HasStoreDir r - ) - => NixSerializer r SError BuildResult -buildResult = Serializer - { getS = do - pv <- Control.Monad.Reader.asks hasProtoVersion - - buildResultStatus <- getS enum - buildResultErrorMessage <- getS maybeText - - ( buildResultTimesBuilt - , buildResultIsNonDeterministic - , buildResultStartTime - , buildResultStopTime - ) <- - if protoVersion_minor pv >= 29 - then do - tb <- (\case 0 -> Nothing; x -> Just x) <$> getS int - nondet <- getS bool - start <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time - end <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time - pure $ (tb, pure nondet, start, end) - else pure $ (Nothing, Nothing, Nothing, Nothing) - - buildResultBuiltOutputs <- - if protoVersion_minor pv >= 28 - then - pure - . Data.Map.Strict.fromList - . map (\(_, (a, b)) -> (a, b)) - . Data.Map.Strict.toList - <$> getS (mapS derivationOutputTyped realisationWithId) - else pure Nothing - pure BuildResult{..} - - , putS = \BuildResult{..} -> do - pv <- Control.Monad.Reader.asks hasProtoVersion - - putS enum buildResultStatus - putS maybeText buildResultErrorMessage - Control.Monad.when (protoVersion_minor pv >= 29) $ do - putS int $ Data.Maybe.fromMaybe 0 buildResultTimesBuilt - putS bool $ Data.Maybe.fromMaybe False buildResultIsNonDeterministic - putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime - putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime - Control.Monad.when (protoVersion_minor pv >= 28) - $ putS (mapS derivationOutputTyped realisationWithId) - $ Data.Map.Strict.fromList - $ map (\(a, b) -> (a, (a, b))) - $ Data.Map.Strict.toList - $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs - } - where - t0 :: UTCTime - t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 - -- * Logger data LoggerSError @@ -1414,5 +1335,103 @@ storeRequest = Serializer -- * Reply data ReplySError - = ReplySError_Prim SError + = ReplySError_PrimGet SError + | ReplySError_PrimPut SError + | ReplySError_DerivationOutput SError + | ReplySError_Realisation SError + | ReplySError_RealisationWithId SError deriving (Eq, Ord, Generic, Show) + +mapGetER + :: Functor m + => SerialT r SError m a + -> SerialT r ReplySError m a +mapGetER = mapErrorST ReplySError_PrimGet + +mapPutER + :: Functor m + => SerialT r SError m a + -> SerialT r ReplySError m a +mapPutER = mapErrorST ReplySError_PrimPut + +-- *** Realisation + +derivationOutputTyped :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName) +derivationOutputTyped = mapErrorS ReplySError_DerivationOutput $ + mapPrismSerializer + ( Data.Bifunctor.first SError_DerivationOutput + . System.Nix.Realisation.derivationOutputParser + System.Nix.OutputName.mkOutputName + ) + ( Data.Text.Lazy.toStrict + . Data.Text.Lazy.Builder.toLazyText + . System.Nix.Realisation.derivationOutputBuilder + System.Nix.OutputName.unOutputName + ) + text + +realisation :: NixSerializer r ReplySError Realisation +realisation = mapErrorS ReplySError_Realisation json + +realisationWithId :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName, Realisation) +realisationWithId = mapErrorS ReplySError_RealisationWithId json + +-- *** BuildResult + +buildResult + :: ( HasProtoVersion r + , HasStoreDir r + ) + => NixSerializer r ReplySError BuildResult +buildResult = Serializer + { getS = do + pv <- Control.Monad.Reader.asks hasProtoVersion + + buildResultStatus <- mapGetER $ getS enum + buildResultErrorMessage <- mapGetER $ getS maybeText + + ( buildResultTimesBuilt + , buildResultIsNonDeterministic + , buildResultStartTime + , buildResultStopTime + ) <- + if protoVersion_minor pv >= 29 + then mapGetER $ do + tb <- (\case 0 -> Nothing; x -> Just x) <$> getS int + nondet <- getS bool + start <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time + end <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time + pure $ (tb, pure nondet, start, end) + else pure $ (Nothing, Nothing, Nothing, Nothing) + + buildResultBuiltOutputs <- + if protoVersion_minor pv >= 28 + then + pure + . Data.Map.Strict.fromList + . map (\(_, (a, b)) -> (a, b)) + . Data.Map.Strict.toList + <$> getS (mapS derivationOutputTyped realisationWithId) + else pure Nothing + pure BuildResult{..} + + , putS = \BuildResult{..} -> do + pv <- Control.Monad.Reader.asks hasProtoVersion + + mapPutER $ putS enum buildResultStatus + mapPutER $ putS maybeText buildResultErrorMessage + Control.Monad.when (protoVersion_minor pv >= 29) $ mapPutER $ do + putS int $ Data.Maybe.fromMaybe 0 buildResultTimesBuilt + putS bool $ Data.Maybe.fromMaybe False buildResultIsNonDeterministic + putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime + putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime + Control.Monad.when (protoVersion_minor pv >= 28) + $ putS (mapS derivationOutputTyped realisationWithId) + $ Data.Map.Strict.fromList + $ map (\(a, b) -> (a, (a, b))) + $ Data.Map.Strict.toList + $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs + } + where + t0 :: UTCTime + t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs index 40421b9..392a043 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -23,7 +23,7 @@ instance StoreReply Bool where getReplyS = mapPrimE bool instance StoreReply BuildResult where - getReplyS = mapPrimE buildResult + getReplyS = buildResult instance StoreReply StorePath where getReplyS = mapPrimE storePath @@ -31,4 +31,4 @@ instance StoreReply StorePath where mapPrimE :: NixSerializer r SError a -> NixSerializer r ReplySError a -mapPrimE = mapErrorS ReplySError_Prim +mapPrimE = mapErrorS ReplySError_PrimGet From 5aa62fd8da60eb161b820ca7b0c302a0e1fc4418 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 08:27:04 +0100 Subject: [PATCH 092/104] remote: NarSource not in GADT pans out --- .../src/System/Nix/Store/Remote/Types/StoreRequest.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs index 1e74c2e..bdb12c9 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -36,15 +36,6 @@ data StoreRequest :: Type -> Type where :: StorePathName -- ^ Name part of the newly created @StorePath@ -> FileIngestionMethod -- ^ Add target directory recursively -> Some HashAlgo -- ^ Nar hashing algorithm --- -> (forall m . MonadIO m => NarSource m) -- ^ provide nar stream --- Not part of StoreRequest --- as it would require StoreRequest (m :: Type -> Type) :: Type -> Type --- for which we cannot derive anything --- --- Also the thing is the only special case --- and it is always sent *after* the other --- information so it can be handled --- separately after that. Hopefully. -> RepairMode -- ^ Only used by local store backend -> StoreRequest StorePath From 77fe9f9acda2f7cba5aa142e519b3f934c0d1cdb Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 08:35:25 +0100 Subject: [PATCH 093/104] remote: add gcResult serializer --- .../src/System/Nix/Store/Remote/Serializer.hs | 18 ++++++++++++++++++ .../Nix/Store/Remote/Types/StoreReply.hs | 4 ++++ hnix-store-remote/tests/NixSerializerSpec.hs | 3 +++ 3 files changed, 25 insertions(+) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index b3d3f79..47249db 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -90,6 +90,8 @@ module System.Nix.Store.Remote.Serializer , realisationWithId -- *** BuildResult , buildResult + -- *** GCResult + , gcResult ) where import Control.Monad.Except (MonadError, throwError, ) @@ -1338,6 +1340,7 @@ data ReplySError = ReplySError_PrimGet SError | ReplySError_PrimPut SError | ReplySError_DerivationOutput SError + | ReplySError_GCResult SError | ReplySError_Realisation SError | ReplySError_RealisationWithId SError deriving (Eq, Ord, Generic, Show) @@ -1435,3 +1438,18 @@ buildResult = Serializer where t0 :: UTCTime t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 + +gcResult + :: HasStoreDir r + => NixSerializer r ReplySError GCResult +gcResult = mapErrorS ReplySError_GCResult $ Serializer + { getS = do + gcResult_deletedPaths <- getS (hashSet storePath) + gcResult_bytesFreed <- getS int + Control.Monad.void $ getS (int @Word64) -- obsolete + pure GCResult{..} + , putS = \GCResult{..} -> do + putS (hashSet storePath) gcResult_deletedPaths + putS int gcResult_bytesFreed + putS (int @Word64) 0 -- obsolete + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs index 392a043..94fa2c0 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -5,6 +5,7 @@ module System.Nix.Store.Remote.Types.StoreReply import System.Nix.Build (BuildResult) import System.Nix.StorePath (HasStoreDir(..), StorePath) import System.Nix.Store.Remote.Serializer +import System.Nix.Store.Remote.Types.GC (GCResult) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion) -- | Get @NixSerializer@ for some type @a@ @@ -25,6 +26,9 @@ instance StoreReply Bool where instance StoreReply BuildResult where getReplyS = buildResult +instance StoreReply GCResult where + getReplyS = gcResult + instance StoreReply StorePath where getReplyS = mapPrimE storePath diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 219d713..e50a1f0 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -149,6 +149,9 @@ spec = parallel $ do forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig))) $ roundtripSReader @TestStoreConfig storeRequest testStoreConfig + describe "StoreReply" $ do + prop "GCResult" $ roundtripSReader @StoreDir gcResult + restrictProtoVersion :: ProtoVersion -> Some StoreRequest -> Bool restrictProtoVersion v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False restrictProtoVersion _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty From c841f93b695bc4ab01c0214655b2fa878ade665c Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 08:37:29 +0100 Subject: [PATCH 094/104] remote: align GC(Options|Result) record field naming --- .../src/System/Nix/Store/Remote.hs | 6 ++--- .../src/System/Nix/Store/Remote/Serializer.hs | 24 +++++++++---------- .../src/System/Nix/Store/Remote/Types/GC.hs | 12 +++++----- hnix-store-remote/tests-io/NixDaemon.hs | 4 ++-- 4 files changed, 23 insertions(+), 23 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index af830a7..3aacb63 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -234,9 +234,9 @@ deleteSpecific paths = do putInt (0::Int) putInt (0::Int) getSocketIncremental $ do - gcResult_deletedPaths <- getPathsOrFail storeDir - gcResult_bytesFreed <- getInt - -- TODO: who knows + gcResultDeletedPaths <- getPathsOrFail storeDir + gcResultBytesFreed <- getInt + -- TODO: obsolete _ :: Int <- getInt pure GCResult{..} diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 47249db..c5fd1b3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -1101,10 +1101,10 @@ storeRequest = Serializer pure $ Some (BuildDerivation path drv buildMode') WorkerOp_CollectGarbage -> mapGetE $ do - gcOptions_operation <- getS enum - gcOptions_pathsToDelete <- getS (hashSet storePath) - gcOptions_ignoreLiveness <- getS bool - gcOptions_maxFreed <- getS int + gcOptionsOperation <- getS enum + gcOptionsPathsToDelete <- getS (hashSet storePath) + gcOptionsIgnoreLiveness <- getS bool + gcOptionsMaxFreed <- getS int -- obsolete fields Control.Monad.forM_ [0..(2 :: Word8)] $ pure $ getS (int @Word8) @@ -1238,10 +1238,10 @@ storeRequest = Serializer Some (CollectGarbage GCOptions{..}) -> mapPutE $ do putS workerOp WorkerOp_CollectGarbage - putS enum gcOptions_operation - putS (hashSet storePath) gcOptions_pathsToDelete - putS bool gcOptions_ignoreLiveness - putS int gcOptions_maxFreed + putS enum gcOptionsOperation + putS (hashSet storePath) gcOptionsPathsToDelete + putS bool gcOptionsIgnoreLiveness + putS int gcOptionsMaxFreed -- obsolete fields Control.Monad.forM_ [0..(2 :: Word8)] $ pure $ putS int (0 :: Word8) @@ -1444,12 +1444,12 @@ gcResult => NixSerializer r ReplySError GCResult gcResult = mapErrorS ReplySError_GCResult $ Serializer { getS = do - gcResult_deletedPaths <- getS (hashSet storePath) - gcResult_bytesFreed <- getS int + gcResultDeletedPaths <- getS (hashSet storePath) + gcResultBytesFreed <- getS int Control.Monad.void $ getS (int @Word64) -- obsolete pure GCResult{..} , putS = \GCResult{..} -> do - putS (hashSet storePath) gcResult_deletedPaths - putS int gcResult_bytesFreed + putS (hashSet storePath) gcResultDeletedPaths + putS int gcResultBytesFreed putS (int @Word64) 0 -- obsolete } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs index 8fdda8b..b707ca6 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs @@ -24,24 +24,24 @@ data GCAction -- | Garbage collector operation options data GCOptions = GCOptions { -- | Operation - gcOptions_operation :: GCAction + gcOptionsOperation :: GCAction -- | If set, then reachability from the roots is ignored (unused) - , gcOptions_ignoreLiveness :: Bool + , gcOptionsIgnoreLiveness :: Bool -- | Paths to delete for @GCAction_DeleteSpecific@ - , gcOptions_pathsToDelete :: HashSet StorePath + , gcOptionsPathsToDelete :: HashSet StorePath -- | Stop after `gcOptions_maxFreed` bytes have been freed - , gcOptions_maxFreed :: Word64 + , gcOptionsMaxFreed :: Word64 } deriving (Eq, Generic, Ord, Show) -- | Result of the garbage collection operation data GCResult = GCResult { -- | Depending on the action, the GC roots, -- or the paths that would be or have been deleted - gcResult_deletedPaths :: HashSet StorePath + gcResultDeletedPaths :: HashSet StorePath -- | The number of bytes that would be or was freed for -- -- - @GCAction_ReturnDead@ -- - @GCAction_DeleteDead@ -- - @GCAction_DeleteSpecific@ - , gcResult_bytesFreed :: Word64 + , gcResultBytesFreed :: Word64 } deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index a83a9c8..ac847bd 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemon.hs @@ -297,6 +297,6 @@ spec_protocol = Hspec.around withNixDaemon $ removeFile $ mconcat [ tempRootsDir, "/", entry ] GCResult{..} <- deleteSpecific (HS.fromList [path]) - gcResult_deletedPaths `shouldBe` HS.fromList [path] - gcResult_bytesFreed `shouldBe` 4 + gcResultDeletedPaths `shouldBe` HS.fromList [path] + gcResultBytesFreed `shouldBe` 4 From d18a014103ffd71135ecb456017b4adef36d73b8 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 08:45:53 +0100 Subject: [PATCH 095/104] remote: add Query.Missing serializer --- .../src/System/Nix/Store/Remote/Arbitrary.hs | 13 ++++++++--- .../src/System/Nix/Store/Remote/Serializer.hs | 23 +++++++++++++++++++ .../Nix/Store/Remote/Types/StoreReply.hs | 4 ++++ hnix-store-remote/tests/NixSerializerSpec.hs | 1 + 4 files changed, 38 insertions(+), 3 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index 56e39b1..a487fa1 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -78,9 +78,6 @@ deriving via GenericArbitrary GCAction deriving via GenericArbitrary GCOptions instance Arbitrary GCOptions -deriving via GenericArbitrary GCResult - instance Arbitrary GCResult - -- * Handshake deriving via GenericArbitrary WorkerMagic @@ -94,6 +91,8 @@ deriving via GenericArbitrary TrustedFlag deriving via GenericArbitrary WorkerOp instance Arbitrary WorkerOp +-- ** Request + instance Arbitrary (Some StoreRequest) where arbitrary = oneof [ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair) @@ -121,3 +120,11 @@ instance Arbitrary (Some StoreRequest) where , pure $ Some SyncWithGC , Some <$> (VerifyStore <$> arbitrary <*> arbitrary) ] + +-- ** Reply + +deriving via GenericArbitrary GCResult + instance Arbitrary GCResult + +deriving via GenericArbitrary Missing + instance Arbitrary Missing diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index c5fd1b3..39ca8ac 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -92,6 +92,8 @@ module System.Nix.Store.Remote.Serializer , buildResult -- *** GCResult , gcResult + -- *** Missing + , missing ) where import Control.Monad.Except (MonadError, throwError, ) @@ -1341,6 +1343,7 @@ data ReplySError | ReplySError_PrimPut SError | ReplySError_DerivationOutput SError | ReplySError_GCResult SError + | ReplySError_Missing SError | ReplySError_Realisation SError | ReplySError_RealisationWithId SError deriving (Eq, Ord, Generic, Show) @@ -1453,3 +1456,23 @@ gcResult = mapErrorS ReplySError_GCResult $ Serializer putS int gcResultBytesFreed putS (int @Word64) 0 -- obsolete } + +missing + :: HasStoreDir r + => NixSerializer r ReplySError Missing +missing = mapErrorS ReplySError_Missing $ Serializer + { getS = do + missingWillBuild <- getS (hashSet storePath) + missingWillSubstitute <- getS (hashSet storePath) + missingUnknownPaths <- getS (hashSet storePath) + missingDownloadSize <- getS int + missingNarSize <- getS int + + pure Missing{..} + , putS = \Missing{..} -> do + putS (hashSet storePath) missingWillBuild + putS (hashSet storePath) missingWillSubstitute + putS (hashSet storePath) missingUnknownPaths + putS int missingDownloadSize + putS int missingNarSize + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs index 94fa2c0..185147d 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -6,6 +6,7 @@ import System.Nix.Build (BuildResult) import System.Nix.StorePath (HasStoreDir(..), StorePath) import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.GC (GCResult) +import System.Nix.Store.Remote.Types.Query.Missing (Missing) import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion) -- | Get @NixSerializer@ for some type @a@ @@ -29,6 +30,9 @@ instance StoreReply BuildResult where instance StoreReply GCResult where getReplyS = gcResult +instance StoreReply Missing where + getReplyS = missing + instance StoreReply StorePath where getReplyS = mapPrimE storePath diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index e50a1f0..d2ba74d 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -151,6 +151,7 @@ spec = parallel $ do describe "StoreReply" $ do prop "GCResult" $ roundtripSReader @StoreDir gcResult + prop "Missing" $ roundtripSReader @StoreDir missing restrictProtoVersion :: ProtoVersion -> Some StoreRequest -> Bool restrictProtoVersion v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False From 48697e1efee2ba1d8f9e8732d542409bd72f0b92 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 08:57:08 +0100 Subject: [PATCH 096/104] remote: add maybePathMetadata serializer --- .../src/System/Nix/Store/Remote/Serializer.hs | 27 ++++++++++++++++--- .../Nix/Store/Remote/Types/StoreReply.hs | 4 +++ hnix-store-remote/tests/NixSerializerSpec.hs | 1 + 3 files changed, 29 insertions(+), 3 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 39ca8ac..274aa67 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -94,6 +94,8 @@ module System.Nix.Store.Remote.Serializer , gcResult -- *** Missing , missing + -- *** Maybe (Metadata StorePath) + , maybePathMetadata ) where import Control.Monad.Except (MonadError, throwError, ) @@ -562,9 +564,11 @@ pathMetadata = Serializer metadataReferences <- getS $ hashSet storePath metadataRegistrationTime <- getS time - metadataNarBytes <- (\case - 0 -> Nothing - size -> Just size) <$> getS int + metadataNarBytes <- + (\case + 0 -> Nothing + size -> Just size + ) <$> getS int metadataTrust <- getS storePathTrust metadataSigs <- getS $ set narSignature @@ -1343,6 +1347,7 @@ data ReplySError | ReplySError_PrimPut SError | ReplySError_DerivationOutput SError | ReplySError_GCResult SError + | ReplySError_Metadata SError | ReplySError_Missing SError | ReplySError_Realisation SError | ReplySError_RealisationWithId SError @@ -1476,3 +1481,19 @@ missing = mapErrorS ReplySError_Missing $ Serializer putS int missingDownloadSize putS int missingNarSize } + +-- *** Maybe (Metadata StorePath) + +maybePathMetadata + :: HasStoreDir r + => NixSerializer r ReplySError (Maybe (Metadata StorePath)) +maybePathMetadata = mapErrorS ReplySError_Metadata $ Serializer + { getS = do + valid <- getS bool + if valid + then pure <$> getS pathMetadata + else pure Nothing + , putS = \case + Nothing -> putS bool False + Just pm -> putS bool True >> putS pathMetadata pm + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs index 185147d..6bf1d15 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -4,6 +4,7 @@ module System.Nix.Store.Remote.Types.StoreReply import System.Nix.Build (BuildResult) import System.Nix.StorePath (HasStoreDir(..), StorePath) +import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.GC (GCResult) import System.Nix.Store.Remote.Types.Query.Missing (Missing) @@ -33,6 +34,9 @@ instance StoreReply GCResult where instance StoreReply Missing where getReplyS = missing +instance StoreReply (Maybe (Metadata StorePath)) where + getReplyS = maybePathMetadata + instance StoreReply StorePath where getReplyS = mapPrimE storePath diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index d2ba74d..df9082a 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -152,6 +152,7 @@ spec = parallel $ do describe "StoreReply" $ do prop "GCResult" $ roundtripSReader @StoreDir gcResult prop "Missing" $ roundtripSReader @StoreDir missing + prop "Maybe (Metadata StorePath)" $ roundtripSReader @StoreDir maybePathMetadata restrictProtoVersion :: ProtoVersion -> Some StoreRequest -> Bool restrictProtoVersion v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False From 04a38e8c46ded6c65b027269e8876c060b5eb2db Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 09:13:24 +0100 Subject: [PATCH 097/104] remote: add opSuccess serializer for StoreReply () --- .../src/System/Nix/Store/Remote/Serializer.hs | 18 +++++++++++++++++- .../Nix/Store/Remote/Types/StoreReply.hs | 3 +++ hnix-store-remote/tests/NixSerializerSpec.hs | 1 + 3 files changed, 21 insertions(+), 1 deletion(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 274aa67..e8d951a 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -84,6 +84,7 @@ module System.Nix.Store.Remote.Serializer , storeRequest -- ** Reply , ReplySError(..) + , opSuccess -- *** Realisation , derivationOutputTyped , realisation @@ -1340,7 +1341,7 @@ storeRequest = Serializer -> m a reserved = throwError . RequestSError_ReservedOp --- * Reply +-- ** Reply data ReplySError = ReplySError_PrimGet SError @@ -1351,6 +1352,7 @@ data ReplySError | ReplySError_Missing SError | ReplySError_Realisation SError | ReplySError_RealisationWithId SError + | ReplySError_UnexpectedFalseOpSuccess deriving (Eq, Ord, Generic, Show) mapGetER @@ -1365,6 +1367,20 @@ mapPutER -> SerialT r ReplySError m a mapPutER = mapErrorST ReplySError_PrimPut +-- | Parse a bool returned at the end of simple operations. +-- This is always 1 (@True@) so we assert that it really is so. +-- Errors for these operations are indicated via @Logger_Error@. +opSuccess :: NixSerializer r ReplySError () +opSuccess = Serializer + { getS = do + retCode <- mapGetER $ getS bool + Control.Monad.unless + (retCode == True) + $ throwError ReplySError_UnexpectedFalseOpSuccess + pure () + , putS = \_ -> mapPutER $ putS bool True + } + -- *** Realisation derivationOutputTyped :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs index 6bf1d15..e022ad5 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -22,6 +22,9 @@ class StoreReply a where ) => NixSerializer r ReplySError a +instance StoreReply () where + getReplyS = opSuccess + instance StoreReply Bool where getReplyS = mapPrimE bool diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index df9082a..3fbf698 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -150,6 +150,7 @@ spec = parallel $ do $ roundtripSReader @TestStoreConfig storeRequest testStoreConfig describe "StoreReply" $ do + prop "()" $ roundtripS opSuccess prop "GCResult" $ roundtripSReader @StoreDir gcResult prop "Missing" $ roundtripSReader @StoreDir missing prop "Maybe (Metadata StorePath)" $ roundtripSReader @StoreDir maybePathMetadata From 774590eb6e945aa0a089cba7ae393f8f6dd80113 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 09:15:44 +0100 Subject: [PATCH 098/104] remote: add StoreReply (HashSet StorePath) & StoreReply (HashSet StorePathName) --- .../src/System/Nix/Store/Remote/Types/StoreReply.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs index e022ad5..08749ad 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -2,8 +2,9 @@ module System.Nix.Store.Remote.Types.StoreReply ( StoreReply(..) ) where +import Data.HashSet (HashSet) import System.Nix.Build (BuildResult) -import System.Nix.StorePath (HasStoreDir(..), StorePath) +import System.Nix.StorePath (HasStoreDir(..), StorePath, StorePathName) import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.GC (GCResult) @@ -43,6 +44,12 @@ instance StoreReply (Maybe (Metadata StorePath)) where instance StoreReply StorePath where getReplyS = mapPrimE storePath +instance StoreReply (HashSet StorePath) where + getReplyS = mapPrimE (hashSet storePath) + +instance StoreReply (HashSet StorePathName) where + getReplyS = mapPrimE (hashSet storePathName) + mapPrimE :: NixSerializer r SError a -> NixSerializer r ReplySError a From ddfdb893a65fea7925fc7ef4181d6c2eea365ec6 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 10:08:44 +0100 Subject: [PATCH 099/104] remote: add GCRoot type, serializer, prop --- hnix-store-remote/hnix-store-remote.cabal | 1 + .../src/System/Nix/Store/Remote/Arbitrary.hs | 3 +++ .../src/System/Nix/Store/Remote/Serializer.hs | 21 +++++++++++++++++++ .../src/System/Nix/Store/Remote/Types/GC.hs | 8 +++++++ .../Nix/Store/Remote/Types/StoreReply.hs | 6 +++++- .../Nix/Store/Remote/Types/StoreRequest.hs | 5 ++--- hnix-store-remote/tests/NixSerializerSpec.hs | 1 + 7 files changed, 41 insertions(+), 4 deletions(-) diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 8f010ff..c0712e5 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -131,6 +131,7 @@ library , mtl , QuickCheck , unordered-containers + , unix >= 2.7 , vector hs-source-dirs: src ghc-options: -Wall diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index a487fa1..0b9386f 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -126,5 +126,8 @@ instance Arbitrary (Some StoreRequest) where deriving via GenericArbitrary GCResult instance Arbitrary GCResult +deriving via GenericArbitrary GCRoot + instance Arbitrary GCRoot + deriving via GenericArbitrary Missing instance Arbitrary Missing diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index e8d951a..0989069 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -93,6 +93,8 @@ module System.Nix.Store.Remote.Serializer , buildResult -- *** GCResult , gcResult + -- *** GCResult + , gcRoot -- *** Missing , missing -- *** Maybe (Metadata StorePath) @@ -126,6 +128,7 @@ import qualified Control.Monad.Reader import qualified Data.Attoparsec.Text import qualified Data.Bits import qualified Data.ByteString +import qualified Data.ByteString.Char8 import qualified Data.ByteString.Lazy import qualified Data.HashSet import qualified Data.Map.Strict @@ -1463,6 +1466,8 @@ buildResult = Serializer t0 :: UTCTime t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 +-- *** GCResult + gcResult :: HasStoreDir r => NixSerializer r ReplySError GCResult @@ -1478,6 +1483,22 @@ gcResult = mapErrorS ReplySError_GCResult $ Serializer putS (int @Word64) 0 -- obsolete } +-- *** GCRoot + +gcRoot :: NixSerializer r ReplySError GCRoot +gcRoot = Serializer + { getS = mapGetER $ do + getS byteString >>= \case + p | p == censored -> pure GCRoot_Censored + p -> pure (GCRoot_Path p) + , putS = mapPutER . putS byteString . \case + GCRoot_Censored -> censored + GCRoot_Path p -> p + } + where censored = Data.ByteString.Char8.pack "{censored}" + +-- *** Missing + missing :: HasStoreDir r => NixSerializer r ReplySError Missing diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs index b707ca6..dd3c002 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs @@ -6,12 +6,14 @@ module System.Nix.Store.Remote.Types.GC ( GCAction(..) , GCOptions(..) , GCResult(..) + , GCRoot(..) ) where import Data.HashSet (HashSet) import Data.Word (Word64) import GHC.Generics (Generic) import System.Nix.StorePath (StorePath) +import System.Posix.ByteString (RawFilePath) -- | Garbage collection action data GCAction @@ -45,3 +47,9 @@ data GCResult = GCResult -- - @GCAction_DeleteSpecific@ , gcResultBytesFreed :: Word64 } deriving (Eq, Generic, Ord, Show) + +-- | Used as a part of the result of @FindRoots@ operation +data GCRoot + = GCRoot_Censored -- ^ Source path is censored since the user is not trusted + | GCRoot_Path RawFilePath -- ^ Raw source path + deriving (Eq, Generic, Ord, Show) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs index 08749ad..c6a475d 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -3,11 +3,12 @@ module System.Nix.Store.Remote.Types.StoreReply ) where import Data.HashSet (HashSet) +import Data.Map (Map) import System.Nix.Build (BuildResult) import System.Nix.StorePath (HasStoreDir(..), StorePath, StorePathName) import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.Serializer -import System.Nix.Store.Remote.Types.GC (GCResult) +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) @@ -35,6 +36,9 @@ instance StoreReply BuildResult where instance StoreReply GCResult where getReplyS = gcResult +instance StoreReply (Map GCRoot StorePath) where + getReplyS = mapS gcRoot (mapPrimE storePath) + instance StoreReply Missing where getReplyS = missing diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs index bdb12c9..0ebcf32 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -6,7 +6,6 @@ module System.Nix.Store.Remote.Types.StoreRequest ( StoreRequest(..) ) where -import Data.ByteString (ByteString) import Data.GADT.Compare.TH (deriveGEq, deriveGCompare) import Data.GADT.Show.TH (deriveGShow) import Data.HashSet (HashSet) @@ -24,7 +23,7 @@ import System.Nix.Signature (Signature) import System.Nix.Store.Types (FileIngestionMethod, RepairMode) import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart) import System.Nix.StorePath.Metadata (Metadata) -import System.Nix.Store.Remote.Types.GC (GCOptions, GCResult) +import System.Nix.Store.Remote.Types.GC (GCOptions, GCResult, GCRoot) import System.Nix.Store.Remote.Types.CheckMode (CheckMode) import System.Nix.Store.Remote.Types.Query.Missing (Missing) import System.Nix.Store.Remote.Types.StoreText (StoreText) @@ -89,7 +88,7 @@ data StoreRequest :: Type -> Type where -- | Find garbage collector roots. FindRoots - :: StoreRequest (Map ByteString StorePath) + :: StoreRequest (Map GCRoot StorePath) IsValidPath :: StorePath diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 3fbf698..0fa2115 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -152,6 +152,7 @@ spec = parallel $ do describe "StoreReply" $ do prop "()" $ roundtripS opSuccess prop "GCResult" $ roundtripSReader @StoreDir gcResult + prop "GCRoot" $ roundtripS gcRoot prop "Missing" $ roundtripSReader @StoreDir missing prop "Maybe (Metadata StorePath)" $ roundtripSReader @StoreDir maybePathMetadata From 523e4901379fe6d83e71f1e840df709187f498b5 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 13:43:52 +0100 Subject: [PATCH 100/104] remote: port all operations to GADT based ones --- hnix-store-remote/README.md | 9 +- hnix-store-remote/hnix-store-remote.cabal | 3 + .../src/System/Nix/Store/Remote.hs | 332 +----------------- .../src/System/Nix/Store/Remote/Client.hs | 258 ++++++++++---- .../src/System/Nix/Store/Remote/Logger.hs | 4 +- .../src/System/Nix/Store/Remote/MonadStore.hs | 34 +- .../src/System/Nix/Store/Remote/Serializer.hs | 25 +- .../Nix/Store/Remote/Types/StoreRequest.hs | 6 +- hnix-store-remote/tests-io/NixDaemon.hs | 80 +++-- 9 files changed, 281 insertions(+), 470 deletions(-) diff --git a/hnix-store-remote/README.md b/hnix-store-remote/README.md index d8fa4d5..cb545cd 100644 --- a/hnix-store-remote/README.md +++ b/hnix-store-remote/README.md @@ -16,6 +16,7 @@ via `nix-daemon`. import Control.Monad (void) import Control.Monad.IO.Class (liftIO) +import System.Nix.StorePath (mkStorePathName) import System.Nix.Store.Remote main :: IO () @@ -25,6 +26,12 @@ main = do roots <- findRoots liftIO $ print roots - res <- addTextToStore "hnix-store" "test" mempty RepairMode_DontRepair + res <- case mkStorePathName "hnix-store" of + Left e -> error (show e) + Right name -> + addTextToStore + (StoreText name "Hello World!") + mempty + RepairMode_DontRepair liftIO $ print res ``` diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index c0712e5..a27ae8a 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -156,6 +156,7 @@ executable remote-readme buildable: False build-depends: base >=4.12 && <5 + , hnix-store-core , hnix-store-remote build-tool-depends: markdown-unlit:markdown-unlit @@ -212,6 +213,7 @@ test-suite remote-io , hnix-store-core , hnix-store-nar , hnix-store-remote + , hnix-store-tests , bytestring , containers , crypton @@ -221,6 +223,7 @@ test-suite remote-io , hspec-expectations-lifted , linux-namespaces , process + , some , tasty , tasty-hspec , temporary diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 3aacb63..cf4b23e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -1,34 +1,6 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE LiberalTypeSynonyms #-} -{-# LANGUAGE OverloadedStrings #-} - module System.Nix.Store.Remote ( - -- * Operations - addToStore - , addTextToStore - , addSignatures - , addIndirectRoot - , addTempRoot - , buildPaths - , deleteSpecific - , ensurePath - , findRoots - , isValidPathUncached - , queryValidPaths - , queryAllValidPaths - , querySubstitutablePaths - , queryPathInfoUncached - , queryReferrers - , queryValidDerivers - , queryDerivationOutputs - , queryDerivationOutputNames - , queryPathFromHashPart - , queryMissing - , optimiseStore - , syncWithGC - , verifyStore - , 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 @@ -40,43 +12,16 @@ module System.Nix.Store.Remote , 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.Store.Types (FileIngestionMethod(..), RepairMode(..)) -import System.Nix.Build (BuildMode) -import System.Nix.Hash (NamedAlgo(..), BaseEncoding(Base16), decodeDigestWith) -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.StorePath (StoreDir) import System.Nix.Store.Remote.MonadStore (RemoteStoreT, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed)) -import System.Nix.Store.Remote.Client (Run, runStoreSocket, runOp, runOpArgs, runOpArgsIO, simpleOp, simpleOpArgs) -import System.Nix.Store.Remote.Client (buildDerivation) -import System.Nix.Store.Remote.Socket +import System.Nix.Store.Remote.Client import System.Nix.Store.Remote.Types -import System.Nix.Store.Remote.Serialize.Prim + +import qualified Control.Exception +import qualified Network.Socket -- * Compat @@ -139,268 +84,3 @@ runStoreOpts' sockFamily sockAddr storeRootDir code = { preStoreConfig_socket = soc , preStoreConfig_dir = storeRootDir } - --- * Operations - --- | Pack `Nar` and add it to the store. -addToStore - :: forall a - . (NamedAlgo a) - => StorePathName -- ^ Name part of the newly created `StorePath` - -> NarSource MonadStore -- ^ provide nar stream - -> FileIngestionMethod -- ^ Add target directory recursively - -> RepairMode -- ^ Only used by local store backend - -> MonadStore StorePath -addToStore name source recursive repair = do - Control.Monad.when (repair == RepairMode_DoRepair) - $ error "repairing is not supported when building through the Nix daemon" - - runOpArgsIO WorkerOp_AddToStore $ \yield -> do - yield $ Data.Serialize.Put.runPut $ do - putText $ System.Nix.StorePath.unStorePathName name - putBool - $ not - $ System.Nix.Hash.algoName @a == "sha256" - && recursive == FileIngestionMethod_FileRecursive - putBool (recursive == FileIngestionMethod_FileRecursive) - putText $ System.Nix.Hash.algoName @a - source yield - sockGetPath - --- | Add text to store. --- --- Reference accepts repair but only uses it --- to throw error in case of remote talking to nix-daemon. -addTextToStore - :: Text -- ^ Name of the text - -> Text -- ^ Actual text to add - -> HashSet StorePath -- ^ Set of `StorePath`s that the added text references - -> RepairMode -- ^ Repair mode, must be `RepairMode_DontRepair` for remote backend - -- (only valid for local store) - -> MonadStore StorePath -addTextToStore name text references' repair = do - Control.Monad.when (repair == RepairMode_DoRepair) - $ error "repairing is not supported when building through the Nix daemon" - - storeDir <- getStoreDir - runOpArgs WorkerOp_AddTextToStore $ do - putText name - putText text - putPaths storeDir references' - sockGetPath - -addSignatures :: StorePath -> [ByteString] -> MonadStore () -addSignatures p signatures = do - storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs WorkerOp_AddSignatures $ do - putPath storeDir p - putByteStrings signatures - -addIndirectRoot :: StorePath -> MonadStore () -addIndirectRoot pn = do - storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs WorkerOp_AddIndirectRoot $ putPath storeDir pn - --- | Add temporary garbage collector root. --- --- This root is removed as soon as the client exits. -addTempRoot :: StorePath -> MonadStore () -addTempRoot pn = do - storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs WorkerOp_AddTempRoot $ putPath storeDir pn - --- | Build paths if they are an actual derivations. --- --- If derivation output paths are already valid, do nothing. -buildPaths :: HashSet StorePath -> BuildMode -> MonadStore () -buildPaths ps bm = do - storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs WorkerOp_BuildPaths $ do - putPaths storeDir ps - putInt $ fromEnum bm - --- | Delete store paths -deleteSpecific - :: HashSet StorePath -- ^ Paths to delete - -> MonadStore GCResult -deleteSpecific paths = do - storeDir <- getStoreDir - runOpArgs WorkerOp_CollectGarbage $ do - putEnum GCAction_DeleteSpecific - putPaths storeDir paths - putBool False -- ignoreLiveness - putInt (maxBound :: Word64) -- maxFreedBytes - putInt (0::Int) - putInt (0::Int) - putInt (0::Int) - getSocketIncremental $ do - gcResultDeletedPaths <- getPathsOrFail storeDir - gcResultBytesFreed <- getInt - -- TODO: obsolete - _ :: Int <- getInt - pure GCResult{..} - -ensurePath :: StorePath -> MonadStore () -ensurePath pn = do - storeDir <- getStoreDir - Control.Monad.void - $ simpleOpArgs WorkerOp_EnsurePath - $ putPath storeDir pn - --- | Find garbage collector roots. -findRoots :: MonadStore (Map ByteString StorePath) -findRoots = do - runOp WorkerOp_FindRoots - sd <- getStoreDir - res <- - getSocketIncremental - $ getMany - $ (,) - <$> getByteString - <*> getPath sd - - r <- catRights res - pure $ Data.Map.Strict.fromList r - where - catRights :: [(a, Either InvalidPathError b)] -> MonadStore [(a, b)] - catRights = mapM ex - - ex :: (a, Either InvalidPathError b) -> MonadStore (a, b) - ex (x , Right y) = pure (x, y) - ex (_x, Left e ) = error $ "Unable to decode root: " <> show e - -isValidPathUncached :: StorePath -> MonadStore Bool -isValidPathUncached p = do - storeDir <- getStoreDir - simpleOpArgs WorkerOp_IsValidPath $ putPath storeDir p - --- | Query valid paths from set, optionally try to use substitutes. -queryValidPaths - :: HashSet StorePath -- ^ Set of `StorePath`s to query - -> SubstituteMode -- ^ Try substituting missing paths when `True` - -> MonadStore (HashSet StorePath) -queryValidPaths ps substitute = do - storeDir <- getStoreDir - runOpArgs WorkerOp_QueryValidPaths $ do - putPaths storeDir ps - putBool $ substitute == SubstituteMode_DoSubstitute - sockGetPaths - -queryAllValidPaths :: MonadStore (HashSet StorePath) -queryAllValidPaths = do - runOp WorkerOp_QueryAllValidPaths - sockGetPaths - -querySubstitutablePaths :: HashSet StorePath -> MonadStore (HashSet StorePath) -querySubstitutablePaths ps = do - storeDir <- getStoreDir - runOpArgs WorkerOp_QuerySubstitutablePaths $ putPaths storeDir ps - sockGetPaths - -queryPathInfoUncached :: StorePath -> MonadStore (Metadata StorePath) -queryPathInfoUncached path = do - storeDir <- getStoreDir - runOpArgs WorkerOp_QueryPathInfo $ do - putPath storeDir path - - valid <- sockGetBool - Control.Monad.unless valid $ error "Path is not valid" - - metadataDeriverPath <- sockGetPathMay - - narHashText <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr - let - metadataNarHash = - case - decodeDigestWith @SHA256 Base16 narHashText - of - Left e -> error e - Right d -> System.Nix.Hash.HashAlgo_SHA256 :=> d - - metadataReferences <- sockGetPaths - metadataRegistrationTime <- sockGet getTime - metadataNarBytes <- Just <$> sockGetInt - ultimate <- sockGetBool - - sigStrings <- fmap Data.Text.Encoding.decodeUtf8 <$> sockGetStrings - caString <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr - - let - metadataSigs = case - Data.Set.fromList - <$> mapM System.Nix.Signature.parseNarSignature sigStrings - of - Left e -> error e - Right x -> x - - metadataContentAddress = - if Data.Text.null caString then Nothing else - case - Data.Attoparsec.Text.parseOnly - System.Nix.ContentAddress.contentAddressParser - caString - of - Left e -> error e - Right x -> Just x - - metadataTrust = if ultimate then BuiltLocally else BuiltElsewhere - - pure $ Metadata{..} - -queryReferrers :: StorePath -> MonadStore (HashSet StorePath) -queryReferrers p = do - storeDir <- getStoreDir - runOpArgs WorkerOp_QueryReferrers $ putPath storeDir p - sockGetPaths - -queryValidDerivers :: StorePath -> MonadStore (HashSet StorePath) -queryValidDerivers p = do - storeDir <- getStoreDir - runOpArgs WorkerOp_QueryValidDerivers $ putPath storeDir p - sockGetPaths - -queryDerivationOutputs :: StorePath -> MonadStore (HashSet StorePath) -queryDerivationOutputs p = do - storeDir <- getStoreDir - runOpArgs WorkerOp_QueryDerivationOutputs $ putPath storeDir p - sockGetPaths - -queryDerivationOutputNames :: StorePath -> MonadStore (HashSet StorePath) -queryDerivationOutputNames p = do - storeDir <- getStoreDir - runOpArgs WorkerOp_QueryDerivationOutputNames $ putPath storeDir p - sockGetPaths - -queryPathFromHashPart :: StorePathHashPart -> MonadStore StorePath -queryPathFromHashPart storePathHash = do - runOpArgs WorkerOp_QueryPathFromHashPart - $ putText - $ System.Nix.StorePath.storePathHashPartToText storePathHash - sockGetPath - -queryMissing - :: (HashSet StorePath) - -> MonadStore Missing -queryMissing ps = do - storeDir <- getStoreDir - runOpArgs WorkerOp_QueryMissing $ putPaths storeDir ps - - missingWillBuild <- sockGetPaths - missingWillSubstitute <- sockGetPaths - missingUnknownPaths <- sockGetPaths - missingDownloadSize <- sockGetInt - missingNarSize <- sockGetInt - - pure Missing{..} - -optimiseStore :: MonadStore () -optimiseStore = Control.Monad.void $ simpleOp WorkerOp_OptimiseStore - -syncWithGC :: MonadStore () -syncWithGC = Control.Monad.void $ simpleOp WorkerOp_SyncWithGC - --- returns True on errors -verifyStore :: CheckMode -> RepairMode -> MonadStore Bool -verifyStore check repair = simpleOpArgs WorkerOp_VerifyStore $ do - putBool $ check == CheckMode_DoCheck - putBool $ repair == RepairMode_DoRepair diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index ff99c3a..820747d 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -1,88 +1,57 @@ module System.Nix.Store.Remote.Client - ( simpleOp - , simpleOpArgs - , runOp - , runOpArgs - , runOpArgsIO - , addToStore + ( addToStore + , addTextToStore + , addSignatures + , addTempRoot + , addIndirectRoot + , buildPaths , buildDerivation + , collectGarbage + , ensurePath + , findRoots , isValidPath + , queryValidPaths + , queryAllValidPaths + , querySubstitutablePaths + , queryPathInfo + , queryReferrers + , queryValidDerivers + , queryDerivationOutputs + , queryDerivationOutputNames + , queryPathFromHashPart + , queryMissing + , optimiseStore + , syncWithGC + , verifyStore , module System.Nix.Store.Remote.Client.Core ) where import Control.Monad (when) import Control.Monad.Except (throwError) -import Control.Monad.IO.Class (liftIO) -import Data.Serialize.Put (Put, runPut) +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) -import System.Nix.StorePath (StorePath, StorePathName) -import System.Nix.Store.Remote.Logger (processOutput) +import System.Nix.Signature (Signature) +import System.Nix.StorePath (StorePath, StorePathHashPart, StorePathName) +import System.Nix.StorePath.Metadata (Metadata) import System.Nix.Store.Remote.MonadStore -import System.Nix.Store.Remote.Socket (sockPutS, sockGetS) -import System.Nix.Store.Remote.Serializer (bool, enum, mapErrorS) +import System.Nix.Store.Remote.Types.GC (GCOptions, GCResult, GCRoot) +import System.Nix.Store.Remote.Types.CheckMode (CheckMode) +import System.Nix.Store.Remote.Types.Query.Missing (Missing) import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) -import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp) +import System.Nix.Store.Remote.Types.StoreText (StoreText) +import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode) import System.Nix.Store.Remote.Client.Core import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) -import qualified Data.ByteString -import qualified Network.Socket.ByteString - -simpleOp - :: MonadRemoteStore m - => WorkerOp - -> m Bool -simpleOp op = simpleOpArgs op $ pure () - -simpleOpArgs - :: MonadRemoteStore m - => WorkerOp - -> Put - -> m Bool -simpleOpArgs op args = do - runOpArgs op args - errored <- gotError - if errored - then throwError RemoteStoreError_OperationFailed - else sockGetS $ mapErrorS RemoteStoreError_SerializerGet bool - -runOp - :: MonadRemoteStore m - => WorkerOp - -> m () -runOp op = runOpArgs op $ pure () - -runOpArgs - :: MonadRemoteStore m - => WorkerOp - -> Put - -> m () -runOpArgs op args = - runOpArgsIO - op - (\encode -> encode $ runPut args) - -runOpArgsIO - :: MonadRemoteStore m - => WorkerOp - -> ((Data.ByteString.ByteString -> m ()) - -> m () - ) - -> m () -runOpArgsIO op encoder = do - sockPutS (mapErrorS RemoteStoreError_SerializerPut enum) op - - soc <- getStoreSocket - encoder (liftIO . Network.Socket.ByteString.sendAll soc) - - processOutput - -- | Add `NarSource` to the store addToStore :: MonadRemoteStore m @@ -100,6 +69,48 @@ addToStore name source method hashAlgo repair = do setNarSource source doReq (AddToStore name method hashAlgo repair) +-- | Add @StoreText@ to the store +-- Reference accepts repair but only uses it +-- to throw error in case of remote talking to nix-daemon. +addTextToStore + :: MonadRemoteStore m + => StoreText + -> HashSet StorePath -- ^ Set of `StorePath`s that the added text references + -> RepairMode -- ^ Repair mode, must be `RepairMode_DontRepair` for remote backend + -- (only valid for local store) + -> m StorePath +addTextToStore stext references repair = do + Control.Monad.when + (repair == RepairMode_DoRepair) + $ throwError RemoteStoreError_RapairNotSupportedByRemoteStore + + doReq (AddTextToStore stext references repair) + +-- | Add @Signature@s to a store path +addSignatures + :: MonadRemoteStore m + => StorePath + -> Set Signature + -> m () +addSignatures p signatures = doReq (AddSignatures p signatures) + +-- | Add temporary garbage collector root. +-- +-- This root is removed as soon as the client exits. +addTempRoot + :: MonadRemoteStore m + => StorePath + -> m () +addTempRoot = doReq . AddTempRoot + +-- | Add indirect garbage collector root. +addIndirectRoot + :: MonadRemoteStore m + => StorePath + -> m () +addIndirectRoot = doReq . AddIndirectRoot + +-- | Build a derivation available at @StorePath@ buildDerivation :: MonadRemoteStore m => StorePath @@ -108,5 +119,120 @@ buildDerivation -> m BuildResult buildDerivation a b c = doReq (BuildDerivation a b c) -isValidPath :: MonadRemoteStore m => StorePath -> m Bool +-- | Build paths if they are an actual derivations. +-- +-- If derivation output paths are already valid, do nothing. +buildPaths + :: MonadRemoteStore m + => Set DerivedPath + -> BuildMode + -> m () +buildPaths a b = doReq (BuildPaths a b) + +collectGarbage + :: MonadRemoteStore m + => GCOptions + -> m GCResult +collectGarbage = doReq . CollectGarbage + +ensurePath + :: MonadRemoteStore m + => StorePath + -> m () +ensurePath = doReq . EnsurePath + +-- | Find garbage collector roots. +findRoots + :: MonadRemoteStore m + => m (Map GCRoot StorePath) +findRoots = doReq FindRoots + +isValidPath + :: MonadRemoteStore m + => StorePath + -> m Bool isValidPath = doReq . IsValidPath + +-- | Query valid paths from a set, +-- optionally try to use substitutes +queryValidPaths + :: MonadRemoteStore m + => HashSet StorePath + -- ^ Set of @StorePath@s to query + -> SubstituteMode + -- ^ Try substituting missing paths when @SubstituteMode_DoSubstitute@ + -> m (HashSet StorePath) +queryValidPaths a b = doReq (QueryValidPaths a b) + +-- | Query all valid paths +queryAllValidPaths + :: MonadRemoteStore m + => m (HashSet StorePath) +queryAllValidPaths = doReq QueryAllValidPaths + +-- | Query a set of paths substituable from caches +querySubstitutablePaths + :: MonadRemoteStore m + => HashSet StorePath + -> m (HashSet StorePath) +querySubstitutablePaths = doReq . QuerySubstitutablePaths + +-- | Query path metadata +queryPathInfo + :: MonadRemoteStore m + => StorePath + -> m (Maybe (Metadata StorePath)) +queryPathInfo = doReq . QueryPathInfo + +queryReferrers + :: MonadRemoteStore m + => StorePath + -> m (HashSet StorePath) +queryReferrers = doReq . QueryReferrers + +queryValidDerivers + :: MonadRemoteStore m + => StorePath + -> m (HashSet StorePath) +queryValidDerivers = doReq . QueryValidDerivers + +queryDerivationOutputs + :: MonadRemoteStore m + => StorePath + -> m (HashSet StorePath) +queryDerivationOutputs = doReq . QueryDerivationOutputs + +queryDerivationOutputNames + :: MonadRemoteStore m + => StorePath + -> m (HashSet StorePathName) +queryDerivationOutputNames = doReq . QueryDerivationOutputNames + +queryPathFromHashPart + :: MonadRemoteStore m + => StorePathHashPart + -> m StorePath +queryPathFromHashPart = doReq . QueryPathFromHashPart + +queryMissing + :: MonadRemoteStore m + => Set DerivedPath + -> m Missing +queryMissing = doReq . QueryMissing + +optimiseStore + :: MonadRemoteStore m + => m () +optimiseStore = doReq OptimiseStore + +syncWithGC + :: MonadRemoteStore m + => m () +syncWithGC = doReq SyncWithGC + +verifyStore + :: MonadRemoteStore m + => CheckMode + -> RepairMode + -> m Bool +verifyStore check repair = doReq (VerifyStore check repair) 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 d932432..4e9afa3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -8,7 +8,7 @@ import Data.ByteString (ByteString) import Data.Serialize (Result(..)) import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT) import System.Nix.Store.Remote.Socket (sockGet8) -import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, RemoteStoreError(..), appendLog, getDataSource, getDataSink, getStoreSocket, getProtoVersion, setError) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, RemoteStoreError(..), appendLog, getDataSource, getDataSink, getStoreSocket, getProtoVersion) import System.Nix.Store.Remote.Types.Logger (Logger(..)) import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion) @@ -52,7 +52,7 @@ processOutput = do Right ctrl -> do case ctrl of -- These two terminate the logger loop - e@(Logger_Error _) -> setError >> appendLog e + Logger_Error e -> throwError $ RemoteStoreError_LoggerError e Logger_Last -> appendLog Logger_Last -- Read data from source 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 edd9cd6..debe4e7 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -30,7 +30,7 @@ import Network.Socket (Socket) import System.Nix.Nar (NarSource) import System.Nix.StorePath (HasStoreDir(..), StoreDir) import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, ReplySError, SError) -import System.Nix.Store.Remote.Types.Logger (Logger) +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) @@ -66,6 +66,7 @@ data RemoteStoreError | RemoteStoreError_SerializerRequest RequestSError | RemoteStoreError_SerializerReply ReplySError | RemoteStoreError_IOException SomeException + | 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 @@ -171,33 +172,6 @@ class ( MonadIO m -> m () appendLog = lift . appendLog - setError :: m () - default setError - :: ( MonadTrans t - , MonadRemoteStoreR r m' - , m ~ t m' - ) - => m () - setError = lift setError - - clearError :: m () - default clearError - :: ( MonadTrans t - , MonadRemoteStoreR r m' - , m ~ t m' - ) - => m () - clearError = lift clearError - - gotError :: m Bool - default gotError - :: ( MonadTrans t - , MonadRemoteStoreR r m' - , m ~ t m' - ) - => m Bool - gotError = lift gotError - getStoreDir :: m StoreDir default getStoreDir :: ( MonadTrans t @@ -311,10 +285,6 @@ instance ( MonadIO m $ modify $ \s -> s { remoteStoreState_logs = remoteStoreState_logs s `Data.DList.snoc` x } - setError = RemoteStoreT $ modify $ \s -> s { remoteStoreState_gotError = True } - clearError = RemoteStoreT $ modify $ \s -> s { remoteStoreState_gotError = False } - gotError = remoteStoreState_gotError <$> RemoteStoreT get - setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = pure x } getDataSource = remoteStoreState_mDataSource <$> RemoteStoreT get clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = Nothing } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 0989069..71d8a9a 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -144,11 +144,11 @@ import qualified Data.Time.Clock.POSIX import qualified Data.Vector import Data.Serializer -import System.Nix.Base (BaseEncoding(NixBase32)) +import System.Nix.Base (BaseEncoding(Base16, NixBase32)) import System.Nix.Build (BuildMode, BuildResult(..)) import System.Nix.ContentAddress (ContentAddress) import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) -import System.Nix.DerivedPath (DerivedPath, ParseOutputsError) +import System.Nix.DerivedPath (DerivedPath(..), ParseOutputsError) import System.Nix.Hash (HashAlgo(..)) import System.Nix.JSON () import System.Nix.OutputName (OutputName) @@ -563,7 +563,7 @@ pathMetadata = Serializer { getS = do metadataDeriverPath <- getS maybePath - digest' <- getS $ digest NixBase32 + digest' <- getS $ digest Base16 let metadataNarHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest' metadataReferences <- getS $ hashSet storePath @@ -588,7 +588,7 @@ pathMetadata = Serializer -> SerialT r SError PutM () putNarHash = \case System.Nix.Hash.HashAlgo_SHA256 :=> d - -> putS (digest @SHA256 NixBase32) d + -> putS (digest @SHA256 Base16) d _ -> throwError SError_NarHashMustBeSHA256 putNarHash metadataNarHash @@ -773,20 +773,17 @@ derivedPath = Serializer { getS = do pv <- Control.Monad.Reader.asks hasProtoVersion if pv < ProtoVersion 1 30 - then - throwError - $ SError_NotYetImplemented - "DerivedPath" - (ForPV_Older pv) + then DerivedPath_Opaque <$> getS storePath else getS derivedPathNew , putS = \d -> do pv <- Control.Monad.Reader.asks hasProtoVersion if pv < ProtoVersion 1 30 - then - throwError - $ SError_NotYetImplemented - "DerivedPath" - (ForPV_Older pv) + then case d of + DerivedPath_Opaque p -> putS storePath p + _ -> throwError + $ SError_NotYetImplemented + "DerivedPath_Built" + (ForPV_Older pv) else putS derivedPathNew d } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs index 0ebcf32..a375294 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -53,13 +53,13 @@ data StoreRequest :: Type -> Type where -> Set Signature -> StoreRequest () - -- | Add temporary garbage collector root. - -- - -- This root is removed as soon as the client exits. AddIndirectRoot :: StorePath -> StoreRequest () + -- | Add temporary garbage collector root. + -- + -- This root is removed as soon as the client exits. AddTempRoot :: StorePath -> StoreRequest () diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index ac847bd..4fab4cc 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemon.hs @@ -2,9 +2,10 @@ module NixDaemon where -import Data.Text (Text) import Data.Either (isRight, isLeft) import Data.Bool (bool) +import Data.Some (Some(Some)) +import Data.Text (Text) import Control.Monad (forM_, void) import Control.Monad.IO.Class (liftIO) import qualified System.Environment @@ -14,6 +15,7 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.Either import qualified Data.HashSet as HS import qualified Data.Map.Strict as M +import qualified Data.Set import qualified Data.Text import qualified Data.Text.Encoding import System.Directory @@ -24,8 +26,11 @@ import System.Linux.Namespaces as NS import Test.Hspec (Spec, describe, context) import qualified Test.Hspec as Hspec import Test.Hspec.Expectations.Lifted +import Test.Hspec.Nix (forceRight) import System.FilePath +import System.Nix.Hash (HashAlgo(HashAlgo_SHA256)) import System.Nix.Build +import System.Nix.DerivedPath (DerivedPath(..)) import System.Nix.StorePath import System.Nix.StorePath.Metadata import System.Nix.Store.Remote @@ -156,14 +161,25 @@ itLefts name action = it name action isLeft withPath :: (StorePath -> MonadStore a) -> MonadStore a withPath action = do - path <- addTextToStore "hnix-store" "test" mempty RepairMode_DontRepair + path <- + addTextToStore + (StoreText + (forceRight $ mkStorePathName "hnix-store") + "test" + ) + mempty + RepairMode_DontRepair action path -- | dummy path, adds /dummy with "Hello World" contents dummy :: MonadStore StorePath dummy = do - let name = Data.Either.fromRight (error "impossible") $ mkStorePathName "dummy" - addToStore @SHA256 name (dumpPath "dummy") FileIngestionMethod_Flat RepairMode_DontRepair + addToStore + (forceRight $ mkStorePathName "dummy") + (dumpPath "dummy") + FileIngestionMethod_Flat + (Some HashAlgo_SHA256) + RepairMode_DontRepair invalidPath :: StorePath invalidPath = @@ -172,7 +188,11 @@ invalidPath = withBuilder :: (StorePath -> MonadStore a) -> MonadStore a withBuilder action = do - path <- addTextToStore "builder" builderSh mempty RepairMode_DontRepair + path <- + addTextToStore + (StoreText (forceRight $ mkStorePathName "builder") builderSh) + mempty + RepairMode_DontRepair action path builderSh :: Text @@ -209,24 +229,24 @@ spec_protocol = Hspec.around withNixDaemon $ context "addTextToStore" $ itRights "adds text to store" $ withPath pure - context "isValidPathUncached" $ do + context "isValidPath" $ do itRights "validates path" $ withPath $ \path -> do liftIO $ print path - isValidPathUncached path `shouldReturn` True + isValidPath path `shouldReturn` True itLefts "fails on invalid path" $ mapStoreConfig (\sc -> sc { storeConfig_dir = StoreDir "/asdf" }) - $ isValidPathUncached invalidPath + $ isValidPath invalidPath context "queryAllValidPaths" $ do itRights "empty query" queryAllValidPaths itRights "non-empty query" $ withPath $ \path -> queryAllValidPaths `shouldReturn` HS.fromList [path] - context "queryPathInfoUncached" $ + context "queryPathInfo" $ itRights "queries path info" $ withPath $ \path -> do - meta <- queryPathInfoUncached path - metadataReferences meta `shouldSatisfy` HS.null + meta <- queryPathInfo path + (metadataReferences <$> meta) `shouldBe` (Just mempty) context "ensurePath" $ itRights "simple ensure" $ withPath ensurePath @@ -237,18 +257,17 @@ spec_protocol = Hspec.around withNixDaemon $ context "addIndirectRoot" $ itRights "simple addition" $ withPath addIndirectRoot + let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p] + context "buildPaths" $ do itRights "build Normal" $ withPath $ \path -> do - let pathSet = HS.fromList [path] - buildPaths pathSet BuildMode_Normal + buildPaths (toDerivedPathSet path) BuildMode_Normal itRights "build Check" $ withPath $ \path -> do - let pathSet = HS.fromList [path] - buildPaths pathSet BuildMode_Check + buildPaths (toDerivedPathSet path) BuildMode_Check itLefts "build Repair" $ withPath $ \path -> do - let pathSet = HS.fromList [path] - buildPaths pathSet BuildMode_Repair + buildPaths (toDerivedPathSet path) BuildMode_Repair context "roots" $ context "findRoots" $ do itRights "empty roots" (findRoots `shouldReturn` M.empty) @@ -261,8 +280,7 @@ spec_protocol = Hspec.around withNixDaemon $ context "queryMissing" $ itRights "queries" $ withPath $ \path -> do - let pathSet = HS.fromList [path] - queryMissing pathSet + queryMissing (toDerivedPathSet path) `shouldReturn` Missing { missingWillBuild = mempty @@ -275,9 +293,12 @@ spec_protocol = Hspec.around withNixDaemon $ context "addToStore" $ itRights "adds file to store" $ do fp <- liftIO $ writeSystemTempFile "addition" "lal" - let name = Data.Either.fromRight (error "impossible") $ mkStorePathName "tmp-addition" - res <- addToStore @SHA256 name (dumpPath fp) FileIngestionMethod_Flat RepairMode_DontRepair - liftIO $ print res + addToStore + (forceRight $ mkStorePathName "tmp-addition") + (dumpPath fp) + FileIngestionMethod_Flat + (Some HashAlgo_SHA256) + RepairMode_DontRepair context "with dummy" $ do itRights "adds dummy" dummy @@ -285,10 +306,10 @@ spec_protocol = Hspec.around withNixDaemon $ itRights "valid dummy" $ do path <- dummy liftIO $ print path - isValidPathUncached path `shouldReturn` True + isValidPath path `shouldReturn` True - context "deleteSpecific" $ - itRights "delete a path from the store" $ withPath $ \path -> do + context "collectGarbage" $ do + itRights "delete a specific path from the store" $ withPath $ \path -> do -- clear temp gc roots so the delete works. restarting the nix daemon should also do this... storeDir <- getStoreDir let tempRootsDir = Data.Text.unpack $ mconcat [ Data.Text.Encoding.decodeUtf8 (unStoreDir storeDir), "/../var/nix/temproots/" ] @@ -296,7 +317,14 @@ spec_protocol = Hspec.around withNixDaemon $ liftIO $ forM_ tempRootList $ \entry -> do removeFile $ mconcat [ tempRootsDir, "/", entry ] - GCResult{..} <- deleteSpecific (HS.fromList [path]) + GCResult{..} <- + collectGarbage + GCOptions + { gcOptionsOperation = GCAction_DeleteSpecific + , gcOptionsIgnoreLiveness = False + , gcOptionsPathsToDelete = HS.fromList [path] + , gcOptionsMaxFreed = maxBound + } gcResultDeletedPaths `shouldBe` HS.fromList [path] gcResultBytesFreed `shouldBe` 4 From 28d279b614107a3d166839650ca134fa27a68c90 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 14:52:53 +0100 Subject: [PATCH 101/104] remote: delete obsolete funs from Socket --- .../src/System/Nix/Store/Remote/Socket.hs | 69 +------------------ 1 file changed, 1 insertion(+), 68 deletions(-) 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 14eab2f..ac76f80 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -4,14 +4,11 @@ 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 (Put, runPut) import Network.Socket.ByteString (recv, sendAll) -import System.Nix.StorePath (StorePath) -import System.Nix.Store.Remote.MonadStore (MonadRemoteStore, MonadRemoteStoreR, RemoteStoreError(..), getStoreDir) +import System.Nix.Store.Remote.MonadStore (MonadRemoteStoreR, RemoteStoreError(..)) import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT) -import System.Nix.Store.Remote.Serialize.Prim (getInt, getByteString, getByteStrings, getPath, getPathsOrFail) import System.Nix.Store.Remote.Types (HasStoreSocket(..)) import qualified Control.Exception @@ -114,67 +111,3 @@ sockGetS s = do case res of Right x -> pure x Left e -> throwError e - --- * Obsolete - -getSocketIncremental - :: (MonadRemoteStore m, Show a) - => Get a - -> m a -getSocketIncremental = genericIncremental sockGet8 - -sockGet - :: (MonadRemoteStore m, Show a) - => Get a - -> m a -sockGet = getSocketIncremental - -sockGetInt - :: (Integral a, MonadRemoteStore m, Show a) - => m a -sockGetInt = getSocketIncremental getInt - -sockGetBool - :: MonadRemoteStore m - => m Bool -sockGetBool = (== (1 :: Int)) <$> sockGetInt - -sockGetStr - :: MonadRemoteStore m - => m ByteString -sockGetStr = getSocketIncremental getByteString - -sockGetStrings - :: MonadRemoteStore m - => m [ByteString] -sockGetStrings = getSocketIncremental getByteStrings - -sockGetPath - :: MonadRemoteStore m - => m StorePath -sockGetPath = do - sd <- getStoreDir - pth <- getSocketIncremental (getPath sd) - either - (throwError . RemoteStoreError_Fixme . show) - pure - pth - -sockGetPathMay - :: MonadRemoteStore m - => m (Maybe StorePath) -sockGetPathMay = do - sd <- getStoreDir - pth <- getSocketIncremental (getPath sd) - pure $ - either - (const Nothing) - Just - pth - -sockGetPaths - :: MonadRemoteStore m - => m (HashSet StorePath) -sockGetPaths = do - sd <- getStoreDir - getSocketIncremental (getPathsOrFail sd) From 4123d963b6c070dda0fea1c5e2d7784ea3f7ad8c Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 15:17:03 +0100 Subject: [PATCH 102/104] remote: delete obsolete serialization prims and instances --- hnix-store-remote/hnix-store-remote.cabal | 6 - .../src/Data/Serializer/Example.hs | 53 ++++- .../src/System/Nix/Store/Remote/Serialize.hs | 185 --------------- .../System/Nix/Store/Remote/Serialize/Prim.hs | 215 ------------------ hnix-store-remote/tests/SerializeSpec.hs | 97 -------- 5 files changed, 48 insertions(+), 508 deletions(-) delete mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs delete mode 100644 hnix-store-remote/src/System/Nix/Store/Remote/Serialize/Prim.hs delete mode 100644 hnix-store-remote/tests/SerializeSpec.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index a27ae8a..05c940a 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -81,8 +81,6 @@ library , System.Nix.Store.Remote.Client.Core , System.Nix.Store.Remote.Logger , System.Nix.Store.Remote.MonadStore - , System.Nix.Store.Remote.Serialize - , System.Nix.Store.Remote.Serialize.Prim , System.Nix.Store.Remote.Serializer , System.Nix.Store.Remote.Server , System.Nix.Store.Remote.Socket @@ -174,7 +172,6 @@ test-suite remote Data.SerializerSpec EnumSpec NixSerializerSpec - SerializeSpec build-tool-depends: hspec-discover:hspec-discover build-depends: @@ -183,14 +180,11 @@ test-suite remote , hnix-store-remote , hnix-store-tests , bytestring - , cereal , crypton , some > 1.0.5 && < 2 - , text , time , hspec , QuickCheck - , unordered-containers test-suite remote-io import: tests diff --git a/hnix-store-remote/src/Data/Serializer/Example.hs b/hnix-store-remote/src/Data/Serializer/Example.hs index b02df4e..d7709d3 100644 --- a/hnix-store-remote/src/Data/Serializer/Example.hs +++ b/hnix-store-remote/src/Data/Serializer/Example.hs @@ -39,13 +39,19 @@ import Data.ByteString (ByteString) import Data.Int (Int8) import Data.GADT.Show (GShow(..), defaultGshowsPrec) import Data.Kind (Type) -import Data.Type.Equality -import Data.Serialize.Get (getInt8) -import Data.Serialize.Put (putInt8) +import Data.Type.Equality (TestEquality(..), (:~:)(Refl)) +import Data.Serialize.Get (Get, getInt8) +import Data.Serialize.Put (Putter, PutM, putInt8) import Data.Serializer + ( Serializer(..) + , GetSerializerError + , runGetS + , runPutS + , transformGetError + , transformPutError + ) import Data.Some (Some(..)) -import GHC.Generics -import System.Nix.Store.Remote.Serialize.Prim (getBool, putBool, getEnum, putEnum) +import GHC.Generics (Generic) import Test.QuickCheck (Arbitrary(..), oneof) @@ -274,3 +280,40 @@ cmdSRest = Serializer else lift (putInt8 i) Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b) } + +-- Primitives helpers + +getInt :: Integral a => Get a +getInt = fromIntegral <$> getInt8 + +putInt :: Integral a => Putter a +putInt = putInt8 . fromIntegral + +-- | Deserialize @Bool@ from integer +getBool :: Get Bool +getBool = (getInt :: Get Int8) >>= \case + 0 -> pure False + 1 -> pure True + x -> fail $ "illegal bool value " ++ show x + +-- | Serialize @Bool@ into integer +putBool :: Putter Bool +putBool True = putInt (1 :: Int8) +putBool False = putInt (0 :: Int8) + +-- | Utility toEnum version checking bounds using Bounded class +toEnumCheckBounds :: Enum a => Int -> Either String a +toEnumCheckBounds = \case + x | x < minBound -> Left $ "enum out of min bound " ++ show x + x | x > maxBound -> Left $ "enum out of max bound " ++ show x + x | otherwise -> Right $ toEnum x + +-- | Deserialize @Enum@ to integer +getEnum :: Enum a => Get a +getEnum = + toEnumCheckBounds <$> getInt + >>= either fail pure + +-- | Serialize @Enum@ to integer +putEnum :: Enum a => Putter a +putEnum = putInt . fromEnum diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs deleted file mode 100644 index 2480ae2..0000000 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -{-| -Description : Serialize instances for complex types -Maintainer : srk -|-} -module System.Nix.Store.Remote.Serialize where - -import Data.Serialize (Serialize(..)) -import Data.Serialize.Get (Get) -import Data.Serialize.Put (Putter) -import Data.Text (Text) -import Data.Word (Word8, Word32) - -import qualified Control.Monad -import qualified Data.Bits -import qualified Data.Map -import qualified Data.Set -import qualified Data.Text -import qualified Data.Vector - -import System.Nix.Build (BuildMode, BuildStatus) -import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) -import System.Nix.StorePath (StoreDir, StorePath) -import System.Nix.Store.Remote.Serialize.Prim -import System.Nix.Store.Remote.Types - -instance Serialize Text where - get = getText - put = putText - --- * Build - -instance Serialize BuildMode where - get = getEnum - put = putEnum - -instance Serialize BuildStatus where - get = getEnum - put = putEnum - --- * GCAction --- -instance Serialize GCAction where - get = getEnum - put = putEnum - --- * ProtoVersion - --- protoVersion_major & 0xFF00 --- protoVersion_minor & 0x00FF -instance Serialize ProtoVersion where - get = do - v <- getInt @Word32 - pure ProtoVersion - { protoVersion_major = fromIntegral $ Data.Bits.shiftR v 8 - , protoVersion_minor = fromIntegral $ v Data.Bits..&. 0x00FF - } - put p = - putInt @Word32 - $ ((Data.Bits.shiftL (fromIntegral $ protoVersion_major p :: Word32) 8) - Data.Bits..|. fromIntegral (protoVersion_minor p)) - --- * Derivation - -getDerivation - :: StoreDir - -> Get (Derivation StorePath Text) -getDerivation storeDir = do - outputs <- - Data.Map.fromList - <$> (getMany $ do - outputName <- get - path <- getPathOrFail storeDir - hashAlgo <- get - hash <- get - pure (outputName, DerivationOutput{..}) - ) - - -- Our type is Derivation, but in Nix - -- the type sent over the wire is BasicDerivation - -- which omits inputDrvs - inputDrvs <- pure mempty - inputSrcs <- - Data.Set.fromList - <$> getMany (getPathOrFail storeDir) - - platform <- get - builder <- get - args <- - Data.Vector.fromList - <$> getMany get - - env <- - Data.Map.fromList - <$> getMany ((,) <$> get <*> get) - pure Derivation{..} - -putDerivation :: StoreDir -> Putter (Derivation StorePath Text) -putDerivation storeDir Derivation{..} = do - flip putMany (Data.Map.toList outputs) - $ \(outputName, DerivationOutput{..}) -> do - putText outputName - putPath storeDir path - putText hashAlgo - putText hash - - putMany (putPath storeDir) inputSrcs - putText platform - putText builder - putMany putText args - - flip putMany (Data.Map.toList env) - $ \(a1, a2) -> putText a1 *> putText a2 - --- * Logger - -instance Serialize Activity where - get = - toEnumCheckBounds . (+(-100)) <$> getInt - >>= either fail pure - put = putInt . (+100) . fromEnum - -instance Serialize ActivityID where - get = ActivityID <$> getInt - put (ActivityID aid) = putInt aid - -instance Serialize ActivityResult where - get = - toEnumCheckBounds . (+(-100)) <$> getInt - >>= either fail pure - put = putInt . (+100) . fromEnum - -instance Serialize Field where - get = (getInt :: Get Word8) >>= \case - 0 -> Field_LogInt <$> getInt - 1 -> Field_LogStr <$> getText - x -> fail $ "Unknown log field type: " <> show x - put (Field_LogInt x) = putInt (0 :: Word8) >> putInt x - put (Field_LogStr x) = putInt (1 :: Word8) >> putText x - -instance Serialize Trace where - get = do - tracePosition <- (\case 0 -> Nothing; x -> Just x) <$> getInt @Int - traceHint <- get - pure Trace{..} - put Trace{..} = do - maybe (putInt @Int 0) putInt $ tracePosition - put traceHint - -instance Serialize BasicError where - get = do - basicErrorMessage <- get - basicErrorExitStatus <- getInt - pure BasicError{..} - put BasicError{..} = do - put basicErrorMessage - putInt basicErrorExitStatus - -instance Serialize ErrorInfo where - get = do - etyp <- get @Text - Control.Monad.unless (etyp == Data.Text.pack "Error") - $ fail - $ "get ErrorInfo: received unknown error type" ++ show etyp - errorInfoLevel <- get - _name <- get @Text -- removed error name - errorInfoMessage <- get - errorInfoPosition <- (\case 0 -> Nothing; x -> Just x) <$> getInt @Int - errorInfoTraces <- getMany get - pure ErrorInfo{..} - put ErrorInfo{..} = do - put $ Data.Text.pack "Error" - put errorInfoLevel - put $ Data.Text.pack "Error" -- removed error name - put errorInfoMessage - maybe (putInt @Int 0) putInt $ errorInfoPosition - putMany put errorInfoTraces - -instance Serialize LoggerOpCode where - get = getInt >>= either fail pure . word64ToLoggerOpCode - put = putInt . loggerOpCodeToWord64 - -instance Serialize Verbosity where - get = getEnum - put = putEnum diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize/Prim.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize/Prim.hs deleted file mode 100644 index e69b92e..0000000 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize/Prim.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-| -Description : Nix-like serialization primitives -Maintainer : srk -|-} -module System.Nix.Store.Remote.Serialize.Prim where - -import Data.ByteString (ByteString) -import Data.Fixed (Uni) -import Data.HashSet (HashSet) -import Data.Serialize.Get (Get) -import Data.Serialize.Put (Putter) -import Data.Text (Text) -import Data.Time (NominalDiffTime, UTCTime) -import Data.Word (Word8) -import System.Nix.StorePath (StoreDir, StorePath, InvalidPathError) - -import qualified Control.Monad -import qualified Data.Either -import qualified Data.HashSet -import qualified Data.Serialize.Get -import qualified Data.Serialize.Put -import qualified Data.ByteString -import qualified Data.Text.Encoding -import qualified Data.Time.Clock.POSIX -import qualified System.Nix.StorePath - --- * Int - --- | Deserialize Nix like integer -getInt :: Integral a => Get a -getInt = fromIntegral <$> Data.Serialize.Get.getWord64le - --- | Serialize Nix like integer -putInt :: Integral a => Putter a -putInt = Data.Serialize.Put.putWord64le . fromIntegral - --- * Bool - --- | Deserialize @Bool@ from integer -getBool :: Get Bool -getBool = (getInt :: Get Word8) >>= \case - 0 -> pure False - 1 -> pure True - x -> fail $ "illegal bool value " ++ show x - --- | Serialize @Bool@ into integer -putBool :: Putter Bool -putBool True = putInt (1 :: Int) -putBool False = putInt (0 :: Int) - --- * Enum - --- | Utility toEnum version checking bounds using Bounded class -toEnumCheckBounds :: Enum a => Int -> Either String a -toEnumCheckBounds = \case - x | x < minBound -> Left $ "enum out of min bound " ++ show x - x | x > maxBound -> Left $ "enum out of max bound " ++ show x - x | otherwise -> Right $ toEnum x - --- | Deserialize @Enum@ to integer -getEnum :: Enum a => Get a -getEnum = - toEnumCheckBounds <$> getInt - >>= either fail pure - --- | Serialize @Enum@ to integer -putEnum :: Enum a => Putter a -putEnum = putInt . fromEnum - --- * UTCTime - --- | Deserialize @UTCTime@ from integer --- Only 1 second precision. -getTime :: Get UTCTime -getTime = - Data.Time.Clock.POSIX.posixSecondsToUTCTime - . seconds - <$> getInt - where - -- fancy (*10^12), from Int to Uni to Pico(seconds) - seconds :: Int -> NominalDiffTime - seconds n = realToFrac (toEnum n :: Uni) - --- | Serialize @UTCTime@ to integer --- Only 1 second precision. -putTime :: Putter UTCTime -putTime = - putInt - . seconds - . Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds - where - -- fancy (`div`10^12), from Pico to Uni to Int - seconds :: NominalDiffTime -> Int - seconds = (fromEnum :: Uni -> Int) . realToFrac - --- * Combinators - --- | Deserialize a list -getMany :: Get a -> Get [a] -getMany parser = do - count <- getInt - Control.Monad.replicateM count parser - --- | Serialize a list -putMany :: Foldable t => Putter a -> Putter (t a) -putMany printer xs = do - putInt (length xs) - mapM_ printer xs - --- * ByteString - --- | Deserialize length prefixed string --- into @ByteString@, checking for correct padding -getByteString :: Get ByteString -getByteString = do - len <- getInt - st <- Data.Serialize.Get.getByteString len - Control.Monad.when (len `mod` 8 /= 0) $ do - pads <- unpad $ fromIntegral $ 8 - (len `mod` 8) - Control.Monad.unless - (all (== 0) pads) - $ fail $ "No zeroes" <> show (st, len, pads) - pure st - where unpad x = Control.Monad.replicateM x Data.Serialize.Get.getWord8 - --- | Serialize @ByteString@ using length --- prefixed string packing with padding to 8 bytes -putByteString :: Putter ByteString -putByteString x = do - putInt len - Data.Serialize.Put.putByteString x - Control.Monad.when - (len `mod` 8 /= 0) - $ pad $ 8 - (len `mod` 8) - where - len :: Int - len = fromIntegral $ Data.ByteString.length x - pad count = Control.Monad.replicateM_ count (Data.Serialize.Put.putWord8 0) - --- | Deserialize a list of @ByteString@s -getByteStrings :: Get [ByteString] -getByteStrings = getMany getByteString - --- | Serialize a list of @ByteString@s -putByteStrings :: Foldable t => Putter (t ByteString) -putByteStrings = putMany putByteString - --- * Text - --- | Deserialize @Text@ -getText :: Get Text -getText = Data.Text.Encoding.decodeUtf8 <$> getByteString - --- | Serialize @Text@ -putText :: Putter Text -putText = putByteString . Data.Text.Encoding.encodeUtf8 - --- | Deserialize a list of @Text@s -getTexts :: Get [Text] -getTexts = fmap Data.Text.Encoding.decodeUtf8 <$> getByteStrings - --- | Serialize a list of @Text@s -putTexts :: (Functor f, Foldable f) => Putter (f Text) -putTexts = putByteStrings . fmap Data.Text.Encoding.encodeUtf8 - --- * StorePath - --- | Deserialize @StorePath@, checking --- that @StoreDir@ matches expected value -getPath :: StoreDir -> Get (Either InvalidPathError StorePath) -getPath sd = - System.Nix.StorePath.parsePath sd <$> getByteString - --- | Deserialize @StorePath@, checking --- that @StoreDir@ matches expected value -getPathOrFail :: StoreDir -> Get StorePath -getPathOrFail sd = - getPath sd - >>= either - (fail . show) - pure - --- | Serialize @StorePath@ with its associated @StoreDir@ -putPath :: StoreDir -> Putter StorePath -putPath storeDir = - putByteString - . System.Nix.StorePath.storePathToRawFilePath storeDir - --- | Deserialize a @HashSet@ of @StorePath@s -getPaths :: StoreDir -> Get (HashSet (Either InvalidPathError StorePath)) -getPaths sd = - Data.HashSet.fromList - . fmap (System.Nix.StorePath.parsePath sd) - <$> getByteStrings - --- | Deserialize @StorePath@, checking --- that @StoreDir@ matches expected value -getPathsOrFail :: StoreDir -> Get (HashSet StorePath) -getPathsOrFail sd = do - eps <- - fmap (System.Nix.StorePath.parsePath sd) - <$> getByteStrings - Control.Monad.when (any Data.Either.isLeft eps) - $ fail - $ show - $ Data.Either.lefts eps - pure $ Data.HashSet.fromList $ Data.Either.rights eps - --- | Serialize a @HashSet@ of @StorePath@s -putPaths :: StoreDir -> Putter (HashSet StorePath) -putPaths storeDir = - putByteStrings - . Data.HashSet.toList - . Data.HashSet.map - (System.Nix.StorePath.storePathToRawFilePath storeDir) diff --git a/hnix-store-remote/tests/SerializeSpec.hs b/hnix-store-remote/tests/SerializeSpec.hs deleted file mode 100644 index 1855f47..0000000 --- a/hnix-store-remote/tests/SerializeSpec.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module SerializeSpec (spec) where - -import Data.Serialize (Serialize(..)) -import Data.Serialize.Get (Get, runGet) -import Data.Serialize.Put (Putter, runPut) -import Data.Text (Text) -import Test.Hspec (Expectation, Spec, describe, parallel) -import Test.Hspec.QuickCheck (prop) -import Test.Hspec.Nix (roundtrips) - -import qualified Data.Either -import qualified Data.HashSet - -import System.Nix.Arbitrary () -import System.Nix.Build (BuildMode(..), BuildStatus(..)) -import System.Nix.Derivation (Derivation(inputDrvs)) -import System.Nix.Store.Remote.Arbitrary () -import System.Nix.Store.Remote.Serialize (getDerivation, putDerivation) -import System.Nix.Store.Remote.Serialize.Prim -import System.Nix.Store.Remote.Types - --- | Test for roundtrip using @Putter@ and @Get@ functions -roundtrips2 - :: ( Eq a - , Show a - ) - => Putter a - -> Get a - -> a - -> Expectation -roundtrips2 putter getter = - roundtrips - (runPut . putter) - (runGet getter) - --- | Test for roundtrip using @Serialize@ instance -roundtripS - :: ( Eq a - , Serialize a - , Show a - ) - => a - -> Expectation -roundtripS = - roundtrips - (runPut . put) - (runGet get) - -spec :: Spec -spec = parallel $ do - describe "Prim" $ do - prop "Int" $ roundtrips2 putInt (getInt @Int) - prop "Bool" $ roundtrips2 putBool getBool - prop "ByteString" $ roundtrips2 putByteString getByteString - - describe "Combinators" $ do - prop "Many" $ roundtrips2 (putMany putInt) (getMany (getInt @Int)) - prop "[ByteString]" $ roundtrips2 putByteStrings getByteStrings - prop "Text" $ roundtrips2 putText getText - prop "[Text]" $ roundtrips2 putTexts getTexts - - prop "StorePath" $ \sd -> - roundtrips2 - (putPath sd) - (Data.Either.fromRight undefined <$> getPath sd) - - prop "HashSet StorePath" $ \sd -> - roundtrips2 - (putPaths sd) - (Data.HashSet.map (Data.Either.fromRight undefined) <$> getPaths sd) - - describe "Serialize instances" $ do - prop "Text" $ roundtripS @Text - prop "BuildMode" $ roundtripS @BuildMode - prop "BuildStatus" $ roundtripS @BuildStatus - - prop "ProtoVersion" $ roundtripS @ProtoVersion - - prop "Derivation StorePath Text" $ \sd -> - roundtrips2 - (putDerivation sd) - (getDerivation sd) - -- inputDrvs is not used in remote protocol serialization - . (\drv -> drv { inputDrvs = mempty }) - - describe "Logger" $ do - prop "Activity" $ roundtripS @Activity - prop "ActivityID" $ roundtripS @ActivityID - prop "Activity" $ roundtripS @Activity - prop "Field" $ roundtripS @Field - prop "Trace" $ roundtripS @Trace - prop "BasicError" $ roundtripS @BasicError - prop "ErrorInfo" $ roundtripS @ErrorInfo - prop "LoggerOpCode" $ roundtripS @LoggerOpCode - prop "Verbosity" $ roundtripS @Verbosity From b7a9f91fc057a27d659c3cde984732c5f5b1e13d Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 16:45:41 +0100 Subject: [PATCH 103/104] remote: sort Serializer imports --- .../src/System/Nix/Store/Remote/Serializer.hs | 44 +++++++++---------- 1 file changed, 21 insertions(+), 23 deletions(-) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index 71d8a9a..42f3255 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -114,6 +114,7 @@ import Data.Fixed (Uni) import Data.Hashable (Hashable) import Data.HashSet (HashSet) import Data.Map (Map) +import Data.Serializer import Data.Set (Set) import Data.Some (Some(Some)) import Data.Text (Text) @@ -122,28 +123,6 @@ import Data.Time (NominalDiffTime, UTCTime) import Data.Vector (Vector) import Data.Word (Word8, Word32, Word64) import GHC.Generics (Generic) - -import qualified Control.Monad -import qualified Control.Monad.Reader -import qualified Data.Attoparsec.Text -import qualified Data.Bits -import qualified Data.ByteString -import qualified Data.ByteString.Char8 -import qualified Data.ByteString.Lazy -import qualified Data.HashSet -import qualified Data.Map.Strict -import qualified Data.Maybe -import qualified Data.Serialize.Get -import qualified Data.Serialize.Put -import qualified Data.Set -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder -import qualified Data.Time.Clock.POSIX -import qualified Data.Vector - -import Data.Serializer import System.Nix.Base (BaseEncoding(Base16, NixBase32)) import System.Nix.Build (BuildMode, BuildResult(..)) import System.Nix.ContentAddress (ContentAddress) @@ -159,10 +138,29 @@ import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) import System.Nix.Store.Remote.Types +import qualified Control.Monad +import qualified Control.Monad.Reader import qualified Data.Aeson -import qualified Data.Coerce +import qualified Data.Attoparsec.Text import qualified Data.Bifunctor +import qualified Data.Bits +import qualified Data.ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy +import qualified Data.Coerce +import qualified Data.HashSet +import qualified Data.Map.Strict +import qualified Data.Maybe +import qualified Data.Serialize.Get +import qualified Data.Serialize.Put +import qualified Data.Set import qualified Data.Some +import qualified Data.Text +import qualified Data.Text.Encoding +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import qualified Data.Time.Clock.POSIX +import qualified Data.Vector import qualified System.Nix.Base import qualified System.Nix.ContentAddress import qualified System.Nix.DerivedPath From e5c1492a64d6f39f1eb0d0881e72e8a8b65500f7 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 17:31:47 +0100 Subject: [PATCH 104/104] remote: tests-io cleanup --- hnix-store-remote/hnix-store-remote.cabal | 9 +- hnix-store-remote/tests-io/Driver.hs | 9 - hnix-store-remote/tests-io/Main.hs | 12 + .../{NixDaemon.hs => NixDaemonSpec.hs} | 255 +++++++++++------- hnix-store-remote/tests-io/Spec.hs | 1 - 5 files changed, 175 insertions(+), 111 deletions(-) delete mode 100644 hnix-store-remote/tests-io/Driver.hs create mode 100644 hnix-store-remote/tests-io/Main.hs rename hnix-store-remote/tests-io/{NixDaemon.hs => NixDaemonSpec.hs} (57%) delete mode 100644 hnix-store-remote/tests-io/Spec.hs diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 05c940a..5546c10 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -193,15 +193,12 @@ test-suite remote-io buildable: False type: exitcode-stdio-1.0 - main-is: Driver.hs + main-is: Main.hs hs-source-dirs: tests-io -- See https://github.com/redneb/hs-linux-namespaces/issues/3 ghc-options: -rtsopts -fprof-auto "-with-rtsopts -V0" other-modules: - NixDaemon - , Spec - build-tool-depends: - tasty-discover:tasty-discover + NixDaemonSpec build-depends: base >=4.12 && <5 , hnix-store-core @@ -218,8 +215,6 @@ test-suite remote-io , linux-namespaces , process , some - , tasty - , tasty-hspec , temporary , text , unix diff --git a/hnix-store-remote/tests-io/Driver.hs b/hnix-store-remote/tests-io/Driver.hs deleted file mode 100644 index a5dabaf..0000000 --- a/hnix-store-remote/tests-io/Driver.hs +++ /dev/null @@ -1,9 +0,0 @@ -import NixDaemon -import qualified Spec - --- we run remote tests in --- Linux namespaces to avoid interacting with systems store -main :: IO () -main = do - enterNamespaces - Spec.main diff --git a/hnix-store-remote/tests-io/Main.hs b/hnix-store-remote/tests-io/Main.hs new file mode 100644 index 0000000..41032de --- /dev/null +++ b/hnix-store-remote/tests-io/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import qualified Test.Hspec +import qualified NixDaemonSpec + +-- we run remote tests in +-- Linux namespaces to avoid interacting with systems store +main :: IO () +main = do + NixDaemonSpec.enterNamespaces + Test.Hspec.hspec + NixDaemonSpec.spec diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemonSpec.hs similarity index 57% rename from hnix-store-remote/tests-io/NixDaemon.hs rename to hnix-store-remote/tests-io/NixDaemonSpec.hs index 4fab4cc..3e8aec1 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemonSpec.hs @@ -1,56 +1,67 @@ {-# LANGUAGE OverloadedStrings #-} -module NixDaemon where +module NixDaemonSpec + ( enterNamespaces + , spec + ) where -import Data.Either (isRight, isLeft) -import Data.Bool (bool) +import Control.Monad (forM_, unless, void) +import Control.Monad.IO.Class (liftIO) +import Crypto.Hash (SHA256) import Data.Some (Some(Some)) import Data.Text (Text) -import Control.Monad (forM_, void) -import Control.Monad.IO.Class (liftIO) -import qualified System.Environment -import Control.Exception (bracket) -import Control.Concurrent (threadDelay) -import qualified Data.ByteString.Char8 as BSC +import Test.Hspec (Spec, SpecWith, around, describe, context) +import Test.Hspec.Expectations.Lifted +import Test.Hspec.Nix (forceRight) +import System.FilePath (()) +import System.Linux.Namespaces (Namespace(..), GroupMapping(..), UserMapping(..)) +import System.Nix.Hash (HashAlgo(HashAlgo_SHA256)) +import System.Nix.Build (BuildMode(..)) +import System.Nix.DerivedPath (DerivedPath(..)) +import System.Nix.StorePath (StoreDir(..), StorePath) +import System.Nix.StorePath.Metadata (Metadata(..)) +import System.Nix.Store.Remote +import System.Nix.Store.Remote.MonadStore (MonadRemoteStore) +import System.Process (CreateProcess(..), ProcessHandle) +import qualified Control.Concurrent +import qualified Control.Exception +import qualified Data.ByteString.Char8 import qualified Data.Either -import qualified Data.HashSet as HS -import qualified Data.Map.Strict as M +import qualified Data.HashSet +import qualified Data.Map import qualified Data.Set import qualified Data.Text import qualified Data.Text.Encoding -import System.Directory -import System.IO.Temp -import qualified System.Process as P -import System.Posix.User as U -import System.Linux.Namespaces as NS -import Test.Hspec (Spec, describe, context) -import qualified Test.Hspec as Hspec -import Test.Hspec.Expectations.Lifted -import Test.Hspec.Nix (forceRight) -import System.FilePath -import System.Nix.Hash (HashAlgo(HashAlgo_SHA256)) -import System.Nix.Build -import System.Nix.DerivedPath (DerivedPath(..)) -import System.Nix.StorePath -import System.Nix.StorePath.Metadata -import System.Nix.Store.Remote -import System.Nix.Store.Remote.MonadStore (mapStoreConfig) +import qualified System.Directory +import qualified System.Environment +import qualified System.IO.Temp +import qualified System.Linux.Namespaces +import qualified System.Nix.StorePath +import qualified System.Nix.Nar +import qualified System.Nix.Store.Remote.MonadStore +import qualified System.Posix.User +import qualified System.Process +import qualified Test.Hspec -import Crypto.Hash (SHA256) -import System.Nix.Nar (dumpPath) - -createProcessEnv :: FilePath -> String -> [String] -> IO P.ProcessHandle +createProcessEnv + :: FilePath + -> String + -> [String] + -> IO ProcessHandle createProcessEnv fp proc args = do mPath <- System.Environment.lookupEnv "PATH" (_, _, _, ph) <- - P.createProcess (P.proc proc args) - { P.cwd = Just fp - , P.env = Just $ mockedEnv mPath fp + System.Process.createProcess (System.Process.proc proc args) + { cwd = Just fp + , env = Just $ mockedEnv mPath fp } pure ph -mockedEnv :: Maybe String -> FilePath -> [(String, FilePath)] +mockedEnv + :: Maybe String + -> FilePath + -> [(String, FilePath)] mockedEnv mEnvPath fp = [ ("NIX_STORE_DIR" , fp "store") , ("NIX_LOCALSTATE_DIR", fp "var") @@ -61,14 +72,16 @@ mockedEnv mEnvPath fp = -- , ("NIX_REMOTE", "daemon") ] <> foldMap (\x -> [("PATH", x)]) mEnvPath -waitSocket :: FilePath -> Int -> IO () +waitSocket + :: FilePath + -> Int + -> IO () waitSocket _ 0 = fail "No socket" waitSocket fp x = do - ex <- doesFileExist fp - bool - (threadDelay 100000 >> waitSocket fp (x - 1)) - (pure ()) - ex + ex <- System.Directory.doesFileExist fp + unless ex $ do + Control.Concurrent.threadDelay 100000 + waitSocket fp (x - 1) writeConf :: FilePath -> IO () writeConf fp = @@ -94,77 +107,117 @@ error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e561612 startDaemon :: FilePath - -> IO (P.ProcessHandle, MonadStore a -> Run IO a) + -> IO (ProcessHandle, MonadStore a -> Run IO a) startDaemon fp = do writeConf (fp "etc" "nix.conf") - p <- createProcessEnv fp "nix-daemon" [] + procHandle <- createProcessEnv fp "nix-daemon" [] waitSocket sockFp 30 - pure (p, runStoreOpts sockFp (StoreDir $ BSC.pack $ fp "store")) + pure ( procHandle + , runStoreOpts + sockFp + (StoreDir + $ Data.ByteString.Char8.pack + $ fp "store" + ) + ) where sockFp = fp "var/nix/daemon-socket/socket" enterNamespaces :: IO () enterNamespaces = do - uid <- getEffectiveUserID - gid <- getEffectiveGroupID + uid <- System.Posix.User.getEffectiveUserID + gid <- System.Posix.User.getEffectiveGroupID + + System.Linux.Namespaces.unshare + [User, Network, Mount] - unshare [User, Network, Mount] -- fmap our (parent) uid to root - writeUserMappings Nothing [UserMapping 0 uid 1] + System.Linux.Namespaces.writeUserMappings + Nothing + [ UserMapping + 0 -- inside namespace + uid -- outside namespace + 1 --range + ] + -- fmap our (parent) gid to root group - writeGroupMappings Nothing [GroupMapping 0 gid 1] True + System.Linux.Namespaces.writeGroupMappings + Nothing + [ GroupMapping 0 gid 1 ] + True withNixDaemon - :: ((MonadStore a -> Run IO a) -> IO a) -> IO a + :: ((MonadStore a -> Run IO a) -> IO a) + -> IO a withNixDaemon action = - withSystemTempDirectory "test-nix-store" $ \path -> do + System.IO.Temp.withSystemTempDirectory "test-nix-store" $ \path -> do - mapM_ (createDirectory . snd) - (filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path) + mapM_ (System.Directory.createDirectory . snd) + (filter + ((/= "NIX_REMOTE") . fst) + $ mockedEnv Nothing path) ini <- createProcessEnv path "nix-store" ["--init"] - void $ P.waitForProcess ini + void $ System.Process.waitForProcess ini writeFile (path "dummy") "Hello World" - setCurrentDirectory path + System.Directory.setCurrentDirectory path - bracket (startDaemon path) - (P.terminateProcess . fst) - (action . snd) + Control.Exception.bracket + (startDaemon path) + (System.Process.terminateProcess . fst) + (action . snd) -checks :: (Show a, Show b) => IO (a, b) -> (a -> Bool) -> IO () -checks action check = action >>= (`Hspec.shouldSatisfy` (check . fst)) +checks + :: ( Show a + , Show b + ) + => IO (a, b) + -> (a -> Bool) + -> IO () +checks action check = + action >>= (`Test.Hspec.shouldSatisfy` (check . fst)) it :: (Show a, Show b, Monad m) => String -> m c -> (a -> Bool) - -> Hspec.SpecWith (m () -> IO (a, b)) + -> SpecWith (m () -> IO (a, b)) it name action check = - Hspec.it name $ \run -> run (void $ action) `checks` check + Test.Hspec.it name $ \run -> run (void $ action) `checks` check itRights - :: (Show a, Show b, Show c, Monad m) + :: ( Show a + , Show b + , Show c + , Monad m + ) => String -> m d - -> Hspec.SpecWith (m () -> IO (Either a b, c)) -itRights name action = it name action isRight + -> SpecWith (m () -> IO (Either a b, c)) +itRights name action = it name action Data.Either.isRight itLefts - :: (Show a, Show b, Show c, Monad m) + :: ( Show a + , Show b + , Show c + , Monad m + ) => String -> m d - -> Hspec.SpecWith (m () -> IO (Either a b, c)) -itLefts name action = it name action isLeft + -> SpecWith (m () -> IO (Either a b, c)) +itLefts name action = it name action Data.Either.isLeft -withPath :: (StorePath -> MonadStore a) -> MonadStore a +withPath + :: (StorePath -> MonadStore a) + -> MonadStore a withPath action = do path <- addTextToStore (StoreText - (forceRight $ mkStorePathName "hnix-store") + (forceRight $ System.Nix.StorePath.mkStorePathName "hnix-store") "test" ) mempty @@ -175,22 +228,29 @@ withPath action = do dummy :: MonadStore StorePath dummy = do addToStore - (forceRight $ mkStorePathName "dummy") - (dumpPath "dummy") + (forceRight $ System.Nix.StorePath.mkStorePathName "dummy") + (System.Nix.Nar.dumpPath "dummy") FileIngestionMethod_Flat (Some HashAlgo_SHA256) RepairMode_DontRepair invalidPath :: StorePath invalidPath = - let name = Data.Either.fromRight (error "impossible") $ mkStorePathName "invalid" - in unsafeMakeStorePath (mkStorePathHashPart @SHA256 "invalid") name + let name = forceRight $ System.Nix.StorePath.mkStorePathName "invalid" + in System.Nix.StorePath.unsafeMakeStorePath + (System.Nix.StorePath.mkStorePathHashPart + @SHA256 + "invalid") + name -withBuilder :: (StorePath -> MonadStore a) -> MonadStore a -withBuilder action = do - path <- +_withBuilder + :: MonadRemoteStore m + => (StorePath -> m a) + -> m a +_withBuilder action = do + path <- addTextToStore - (StoreText (forceRight $ mkStorePathName "builder") builderSh) + (StoreText (forceRight $ System.Nix.StorePath.mkStorePathName "builder") builderSh) mempty RepairMode_DontRepair action path @@ -198,8 +258,8 @@ withBuilder action = do builderSh :: Text builderSh = "declare -xpexport > $out" -spec_protocol :: Spec -spec_protocol = Hspec.around withNixDaemon $ +spec :: Spec +spec = around withNixDaemon $ describe "store" $ do @@ -234,14 +294,14 @@ spec_protocol = Hspec.around withNixDaemon $ liftIO $ print path isValidPath path `shouldReturn` True itLefts "fails on invalid path" - $ mapStoreConfig + $ System.Nix.Store.Remote.MonadStore.mapStoreConfig (\sc -> sc { storeConfig_dir = StoreDir "/asdf" }) $ isValidPath invalidPath context "queryAllValidPaths" $ do itRights "empty query" queryAllValidPaths itRights "non-empty query" $ withPath $ \path -> - queryAllValidPaths `shouldReturn` HS.fromList [path] + queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path] context "queryPathInfo" $ itRights "queries path info" $ withPath $ \path -> do @@ -270,11 +330,11 @@ spec_protocol = Hspec.around withNixDaemon $ buildPaths (toDerivedPathSet path) BuildMode_Repair context "roots" $ context "findRoots" $ do - itRights "empty roots" (findRoots `shouldReturn` M.empty) + itRights "empty roots" (findRoots `shouldReturn` mempty) itRights "path added as a temp root" $ withPath $ \_ -> do roots <- findRoots - roots `shouldSatisfy` ((== 1) . M.size) + roots `shouldSatisfy` ((== 1) . Data.Map.size) context "optimiseStore" $ itRights "optimises" optimiseStore @@ -292,10 +352,15 @@ spec_protocol = Hspec.around withNixDaemon $ context "addToStore" $ itRights "adds file to store" $ do - fp <- liftIO $ writeSystemTempFile "addition" "lal" + fp <- + liftIO + $ System.IO.Temp.writeSystemTempFile + "addition" + "yolo" + addToStore - (forceRight $ mkStorePathName "tmp-addition") - (dumpPath fp) + (forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition") + (System.Nix.Nar.dumpPath fp) FileIngestionMethod_Flat (Some HashAlgo_SHA256) RepairMode_DontRepair @@ -305,7 +370,6 @@ spec_protocol = Hspec.around withNixDaemon $ itRights "valid dummy" $ do path <- dummy - liftIO $ print path isValidPath path `shouldReturn` True context "collectGarbage" $ do @@ -313,18 +377,21 @@ spec_protocol = Hspec.around withNixDaemon $ -- 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/" ] - tempRootList <- liftIO $ listDirectory tempRootsDir + tempRootList <- + liftIO + $ System.Directory.listDirectory + tempRootsDir liftIO $ forM_ tempRootList $ \entry -> do - removeFile $ mconcat [ tempRootsDir, "/", entry ] + System.Directory.removeFile + $ mconcat [ tempRootsDir, "/", entry ] GCResult{..} <- collectGarbage GCOptions { gcOptionsOperation = GCAction_DeleteSpecific , gcOptionsIgnoreLiveness = False - , gcOptionsPathsToDelete = HS.fromList [path] + , gcOptionsPathsToDelete = Data.HashSet.fromList [path] , gcOptionsMaxFreed = maxBound } - gcResultDeletedPaths `shouldBe` HS.fromList [path] + gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path] gcResultBytesFreed `shouldBe` 4 - diff --git a/hnix-store-remote/tests-io/Spec.hs b/hnix-store-remote/tests-io/Spec.hs deleted file mode 100644 index 203ed40..0000000 --- a/hnix-store-remote/tests-io/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Spec #-}