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 270931c4..79354cea 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 5d1918d1..47da1bc9 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -24,7 +24,16 @@ 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 qualified Data.Set +--import System.Nix.DerivedPath +import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..)) -- | Test for roundtrip using @NixSerializer@ roundtripSReader @@ -170,6 +179,27 @@ 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 _ (Some (BuildPaths _ _)) = False -- breaks on ! in storeDir +--hacks v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False +--hacks _ (Some (BuildPaths derivedPaths _)) = all nonEmptyOutputsSpec_Names derivedPaths +hacks _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty +hacks _ (Some (QueryMissing _)) = False -- breaks on ! in storeDir +--hacks v (Some (QueryMissing _)) | v < ProtoVersion 1 30 = False +--hacks _ (Some (QueryMissing derivedPaths)) = all nonEmptyOutputsSpec_Names derivedPaths +hacks _ _ = True + +-- TODO: should use NonEmpty? +--nonEmptyOutputsSpec_Names :: DerivedPath -> Bool +--nonEmptyOutputsSpec_Names (DerivedPath_Built _ (OutputsSpec_Names pset)) = +-- not $ Data.Set.null pset +--nonEmptyOutputsSpec_Names _ = True + errorInfoIf :: Bool -> Logger -> Bool errorInfoIf True (Logger_Error (Right x)) = noJust0s x where