Skip to content

Commit e570aed

Browse files
sorkisorki
committed
remote: add storeRequest Serializer, property test
1 parent e1299b5 commit e570aed

File tree

2 files changed

+260
-2
lines changed

2 files changed

+260
-2
lines changed

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

Lines changed: 229 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -69,6 +69,7 @@ module System.Nix.Store.Remote.Serializer
6969
-- * Worker protocol
7070
, storeText
7171
, workerOp
72+
, storeRequest
7273
) where
7374

7475
import Control.Monad.Except (MonadError, throwError, )
@@ -84,7 +85,7 @@ import Data.Hashable (Hashable)
8485
import Data.HashSet (HashSet)
8586
import Data.Map (Map)
8687
import Data.Set (Set)
87-
import Data.Some (Some)
88+
import Data.Some (Some(Some))
8889
import Data.Text (Text)
8990
import Data.Time (NominalDiffTime, UTCTime)
9091
import Data.Vector (Vector)
@@ -942,3 +943,230 @@ storeText = Serializer
942943
workerOp :: NixSerializer r SError WorkerOp
943944
workerOp = enum
944945

946+
storeRequest
947+
:: ( HasProtoVersion r
948+
, HasStoreDir r
949+
)
950+
=> NixSerializer r SError (Some StoreRequest)
951+
storeRequest = Serializer
952+
{ getS = getS workerOp >>= \case
953+
WorkerOp_AddToStore -> do
954+
pathName <- getS storePathName
955+
recursive <- getS enum
956+
hashAlgo <- getS someHashAlgo
957+
repairMode <- getS enum
958+
pure $ Some (AddToStore pathName recursive hashAlgo repairMode)
959+
960+
WorkerOp_AddTextToStore -> do
961+
txt <- getS storeText
962+
paths <- getS (hashSet storePath)
963+
repairMode <- getS enum
964+
pure $ Some (AddTextToStore txt paths repairMode)
965+
966+
WorkerOp_AddSignatures -> do
967+
path <- getS storePath
968+
signatures <- getS (list byteString)
969+
pure $ Some (AddSignatures path signatures)
970+
971+
WorkerOp_AddIndirectRoot ->
972+
Some . AddIndirectRoot <$> getS storePath
973+
974+
WorkerOp_AddTempRoot ->
975+
Some . AddTempRoot <$> getS storePath
976+
977+
WorkerOp_BuildPaths -> do
978+
derived <- getS (set derivedPath)
979+
buildMode' <- getS buildMode
980+
pure $ Some (BuildPaths derived buildMode')
981+
982+
WorkerOp_BuildDerivation -> do
983+
path <- getS storePath
984+
drv <- getS derivation
985+
buildMode' <- getS buildMode
986+
pure $ Some (BuildDerivation path drv buildMode')
987+
988+
WorkerOp_EnsurePath ->
989+
Some . EnsurePath <$> getS storePath
990+
991+
WorkerOp_FindRoots -> do
992+
pure $ Some FindRoots
993+
994+
WorkerOp_IsValidPath ->
995+
Some . IsValidPath <$> getS storePath
996+
997+
WorkerOp_QueryValidPaths -> do
998+
paths <- getS (hashSet storePath)
999+
substituteMode <- getS enum
1000+
pure $ Some (QueryValidPaths paths substituteMode)
1001+
1002+
WorkerOp_QueryAllValidPaths ->
1003+
pure $ Some QueryAllValidPaths
1004+
1005+
WorkerOp_QuerySubstitutablePaths ->
1006+
Some . QuerySubstitutablePaths <$> getS (hashSet storePath)
1007+
1008+
WorkerOp_QueryPathInfo ->
1009+
Some . QueryPathInfo <$> getS storePath
1010+
1011+
WorkerOp_QueryReferrers ->
1012+
Some . QueryReferrers <$> getS storePath
1013+
1014+
WorkerOp_QueryValidDerivers ->
1015+
Some . QueryValidDerivers <$> getS storePath
1016+
1017+
WorkerOp_QueryDerivationOutputs ->
1018+
Some . QueryDerivationOutputs <$> getS storePath
1019+
1020+
WorkerOp_QueryDerivationOutputNames ->
1021+
Some . QueryDerivationOutputNames <$> getS storePath
1022+
1023+
WorkerOp_QueryPathFromHashPart ->
1024+
Some . QueryPathFromHashPart <$> getS storePathHashPart
1025+
1026+
WorkerOp_QueryMissing ->
1027+
Some . QueryMissing <$> getS (set derivedPath)
1028+
1029+
WorkerOp_OptimiseStore ->
1030+
pure $ Some OptimiseStore
1031+
1032+
WorkerOp_SyncWithGC ->
1033+
pure $ Some SyncWithGC
1034+
1035+
WorkerOp_VerifyStore -> do
1036+
checkMode <- getS enum
1037+
repairMode <- getS enum
1038+
1039+
pure $ Some (VerifyStore checkMode repairMode)
1040+
1041+
WorkerOp_Reserved_0__ -> undefined
1042+
WorkerOp_Reserved_2__ -> undefined
1043+
WorkerOp_Reserved_15__ -> undefined
1044+
WorkerOp_Reserved_17__ -> undefined
1045+
1046+
WorkerOp_AddBuildLog -> undefined
1047+
WorkerOp_AddMultipleToStore -> undefined
1048+
WorkerOp_AddToStoreNar -> undefined
1049+
WorkerOp_BuildPathsWithResults -> undefined
1050+
WorkerOp_ClearFailedPaths -> undefined
1051+
WorkerOp_CollectGarbage -> undefined
1052+
WorkerOp_ExportPath -> undefined
1053+
WorkerOp_HasSubstitutes -> undefined
1054+
WorkerOp_ImportPaths -> undefined
1055+
WorkerOp_NarFromPath -> undefined
1056+
WorkerOp_QueryDerivationOutputMap -> undefined
1057+
WorkerOp_QueryDeriver -> undefined
1058+
WorkerOp_QueryFailedPaths -> undefined
1059+
WorkerOp_QueryPathHash -> undefined
1060+
WorkerOp_QueryRealisation -> undefined
1061+
WorkerOp_QuerySubstitutablePathInfo -> undefined
1062+
WorkerOp_QuerySubstitutablePathInfos -> undefined
1063+
WorkerOp_QueryReferences -> undefined
1064+
WorkerOp_RegisterDrvOutput -> undefined
1065+
WorkerOp_SetOptions -> undefined
1066+
1067+
, putS = \case
1068+
Some (AddToStore pathName recursive hashAlgo repairMode) -> do
1069+
putS workerOp WorkerOp_AddToStore
1070+
1071+
putS storePathName pathName
1072+
putS enum recursive
1073+
putS someHashAlgo hashAlgo
1074+
putS enum repairMode
1075+
1076+
Some (AddTextToStore txt paths repairMode) -> do
1077+
putS workerOp WorkerOp_AddTextToStore
1078+
1079+
putS storeText txt
1080+
putS (hashSet storePath) paths
1081+
putS enum repairMode
1082+
1083+
Some (AddSignatures path signatures) -> do
1084+
putS workerOp WorkerOp_AddSignatures
1085+
1086+
putS storePath path
1087+
putS (list byteString) signatures
1088+
1089+
Some (AddIndirectRoot path) -> do
1090+
putS workerOp WorkerOp_AddIndirectRoot
1091+
putS storePath path
1092+
1093+
Some (AddTempRoot path) -> do
1094+
putS workerOp WorkerOp_AddTempRoot
1095+
putS storePath path
1096+
1097+
Some (BuildPaths derived buildMode') -> do
1098+
putS workerOp WorkerOp_BuildPaths
1099+
1100+
putS (set derivedPath) derived
1101+
putS buildMode buildMode'
1102+
1103+
Some (BuildDerivation path drv buildMode') -> do
1104+
putS workerOp WorkerOp_BuildDerivation
1105+
1106+
putS storePath path
1107+
putS derivation drv
1108+
putS buildMode buildMode'
1109+
1110+
Some (EnsurePath path) -> do
1111+
putS workerOp WorkerOp_EnsurePath
1112+
putS storePath path
1113+
1114+
Some FindRoots ->
1115+
putS workerOp WorkerOp_FindRoots
1116+
1117+
Some (IsValidPath path) -> do
1118+
putS workerOp WorkerOp_IsValidPath
1119+
putS storePath path
1120+
1121+
Some (QueryValidPaths paths substituteMode) -> do
1122+
putS workerOp WorkerOp_QueryValidPaths
1123+
1124+
putS (hashSet storePath) paths
1125+
putS enum substituteMode
1126+
1127+
Some QueryAllValidPaths ->
1128+
putS workerOp WorkerOp_QueryAllValidPaths
1129+
1130+
Some (QuerySubstitutablePaths paths) -> do
1131+
putS workerOp WorkerOp_QuerySubstitutablePaths
1132+
putS (hashSet storePath) paths
1133+
1134+
Some (QueryPathInfo path) -> do
1135+
putS workerOp WorkerOp_QueryPathInfo
1136+
putS storePath path
1137+
1138+
Some (QueryReferrers path) -> do
1139+
putS workerOp WorkerOp_QueryReferrers
1140+
putS storePath path
1141+
1142+
Some (QueryValidDerivers path) -> do
1143+
putS workerOp WorkerOp_QueryValidDerivers
1144+
putS storePath path
1145+
1146+
Some (QueryDerivationOutputs path) -> do
1147+
putS workerOp WorkerOp_QueryDerivationOutputs
1148+
putS storePath path
1149+
1150+
Some (QueryDerivationOutputNames path) -> do
1151+
putS workerOp WorkerOp_QueryDerivationOutputNames
1152+
putS storePath path
1153+
1154+
Some (QueryPathFromHashPart pathHashPart) -> do
1155+
putS workerOp WorkerOp_QueryPathFromHashPart
1156+
putS storePathHashPart pathHashPart
1157+
1158+
Some (QueryMissing derived) -> do
1159+
putS workerOp WorkerOp_QueryMissing
1160+
putS (set derivedPath) derived
1161+
1162+
Some OptimiseStore ->
1163+
putS workerOp WorkerOp_OptimiseStore
1164+
1165+
Some SyncWithGC ->
1166+
putS workerOp WorkerOp_SyncWithGC
1167+
1168+
Some (VerifyStore checkMode repairMode) -> do
1169+
putS workerOp WorkerOp_VerifyStore
1170+
putS enum checkMode
1171+
putS enum repairMode
1172+
}

‎hnix-store-remote/tests/NixSerializerSpec.hs

Lines changed: 31 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,16 @@ import System.Nix.StorePath (StoreDir)
2424
import System.Nix.StorePath.Metadata (Metadata(..))
2525
import System.Nix.Store.Remote.Arbitrary ()
2626
import System.Nix.Store.Remote.Serializer
27-
import System.Nix.Store.Remote.Types (ErrorInfo(..), Logger(..), ProtoVersion(..), Trace(..), WorkerOp(..))
27+
import System.Nix.Store.Remote.Types.Logger (ErrorInfo(..), Logger(..), Trace(..))
28+
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..))
29+
import System.Nix.Store.Remote.Types.StoreConfig (TestStoreConfig)
30+
import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp(..))
31+
32+
-- WIP
33+
import Data.Some (Some(Some))
34+
--import qualified Data.Set
35+
--import System.Nix.DerivedPath
36+
import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))
2837

2938
-- | Test for roundtrip using @NixSerializer@
3039
roundtripSReader
@@ -170,6 +179,27 @@ spec = parallel $ do
170179
describe "Worker protocol" $ do
171180
prop "StoreText" $ roundtripS storeText
172181

182+
prop "StoreRequest"
183+
$ \testStoreConfig ->
184+
forAll (arbitrary `suchThat` (hacks (hasProtoVersion testStoreConfig)))
185+
$ roundtripSReader @TestStoreConfig storeRequest testStoreConfig
186+
187+
hacks :: ProtoVersion -> Some StoreRequest -> Bool
188+
hacks _ (Some (BuildPaths _ _)) = False -- breaks on ! in storeDir
189+
--hacks v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False
190+
--hacks _ (Some (BuildPaths derivedPaths _)) = all nonEmptyOutputsSpec_Names derivedPaths
191+
hacks _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty
192+
hacks _ (Some (QueryMissing _)) = False -- breaks on ! in storeDir
193+
--hacks v (Some (QueryMissing _)) | v < ProtoVersion 1 30 = False
194+
--hacks _ (Some (QueryMissing derivedPaths)) = all nonEmptyOutputsSpec_Names derivedPaths
195+
hacks _ _ = True
196+
197+
-- TODO: should use NonEmpty?
198+
--nonEmptyOutputsSpec_Names :: DerivedPath -> Bool
199+
--nonEmptyOutputsSpec_Names (DerivedPath_Built _ (OutputsSpec_Names pset)) =
200+
-- not $ Data.Set.null pset
201+
--nonEmptyOutputsSpec_Names _ = True
202+
173203
errorInfoIf :: Bool -> Logger -> Bool
174204
errorInfoIf True (Logger_Error (Right x)) = noJust0s x
175205
where

0 commit comments

Comments
 (0)