remote: move flags to Types, wrap in newtype

This commit is contained in:
Richard Marko 2023-11-14 12:32:25 +01:00
parent b1e590606e
commit c095d12427
4 changed files with 54 additions and 16 deletions

View File

@ -25,6 +25,6 @@ main = do
roots <- findRoots
liftIO $ print roots
res <- addTextToStore "hnix-store" "test" mempty False
res <- addTextToStore "hnix-store" "test" mempty dontRepair
liftIO $ print res
```

View File

@ -71,9 +71,6 @@ import System.Nix.Store.Remote.Util
import Crypto.Hash ( SHA256 )
import System.Nix.Nar ( NarSource )
type RepairFlag = Bool
type CheckFlag = Bool
type SubstituteFlag = Bool
-- | Pack `Nar` and add it to the store.
addToStore
@ -84,7 +81,10 @@ addToStore
-> Bool -- ^ Add target directory recursively
-> RepairFlag -- ^ Only used by local store backend
-> MonadStore StorePath
addToStore name source recursive _repair = do
addToStore name source recursive repair = do
when (unRepairFlag repair)
$ error "repairing is not supported when building through the Nix daemon"
runOpArgsIO AddToStore $ \yield -> do
yield $ toStrict $ Data.Binary.Put.runPut $ do
putText $ System.Nix.StorePath.unStorePathName name
@ -105,8 +105,9 @@ addTextToStore
-> RepairFlag -- ^ Repair flag, must be `False` in case of remote backend
-> MonadStore StorePath
addTextToStore name text references' repair = do
when repair
when (unRepairFlag repair)
$ error "repairing is not supported when building through the Nix daemon"
storeDir <- getStoreDir
runOpArgs AddTextToStore $ do
putText name
@ -204,7 +205,7 @@ queryValidPaths ps substitute = do
storeDir <- getStoreDir
runOpArgs QueryValidPaths $ do
putPaths storeDir ps
putBool substitute
putBool (unSubstituteFlag substitute)
sockGetPaths
queryAllValidPaths :: MonadStore StorePathSet
@ -321,5 +322,5 @@ syncWithGC = void $ simpleOp SyncWithGC
-- returns True on errors
verifyStore :: CheckFlag -> RepairFlag -> MonadStore Bool
verifyStore check repair = simpleOpArgs VerifyStore $ do
putBool check
putBool repair
putBool $ unCheckFlag check
putBool $ unRepairFlag repair

View File

@ -4,6 +4,18 @@
module System.Nix.Store.Remote.Types
( MonadStore
, StoreConfig(..)
, CheckFlag
, doCheck
, dontCheck
, unCheckFlag
, RepairFlag
, doRepair
, dontRepair
, unRepairFlag
, SubstituteFlag
, doSubstitute
, dontSubstitute
, unSubstituteFlag
, Logger(..)
, Field(..)
, mapStoreDir
@ -29,6 +41,31 @@ data StoreConfig = StoreConfig
, storeSocket :: Socket
}
-- | Check flag, used by @verifyStore@
newtype CheckFlag = CheckFlag { unCheckFlag :: Bool }
deriving (Eq, Ord, Show)
doCheck, dontCheck :: CheckFlag
doCheck = CheckFlag True
dontCheck = CheckFlag False
-- | Repair flag, used by @addToStore@, @addTextToStore@
-- and @verifyStore@
newtype RepairFlag = RepairFlag { unRepairFlag :: Bool }
deriving (Eq, Ord, Show)
doRepair, dontRepair :: RepairFlag
doRepair = RepairFlag True
dontRepair = RepairFlag False
-- | Substitute flag, used by @queryValidPaths@
newtype SubstituteFlag = SubstituteFlag { unSubstituteFlag :: Bool }
deriving (Eq, Ord, Show)
doSubstitute, dontSubstitute :: SubstituteFlag
doSubstitute = SubstituteFlag True
dontSubstitute = SubstituteFlag False
type MonadStore a
= ExceptT
String

View File

@ -154,14 +154,14 @@ itLefts name action = it name action isLeft
withPath :: (StorePath -> MonadStore a) -> MonadStore a
withPath action = do
path <- addTextToStore "hnix-store" "test" (HS.fromList []) False
path <- addTextToStore "hnix-store" "test" mempty dontRepair
action path
-- | dummy path, adds <tmp>/dummpy with "Hello World" contents
dummy :: MonadStore StorePath
dummy = do
let name = Data.Either.fromRight (error "impossible") $ makeStorePathName "dummy"
addToStore @SHA256 name (dumpPath "dummy") False False
addToStore @SHA256 name (dumpPath "dummy") False dontRepair
invalidPath :: StorePath
invalidPath =
@ -170,7 +170,7 @@ invalidPath =
withBuilder :: (StorePath -> MonadStore a) -> MonadStore a
withBuilder action = do
path <- addTextToStore "builder" builderSh (HS.fromList []) False
path <- addTextToStore "builder" builderSh mempty dontRepair
action path
builderSh :: Text
@ -186,14 +186,14 @@ spec_protocol = Hspec.around withNixDaemon $
context "verifyStore" $ do
itRights "check=False repair=False" $
verifyStore False False `shouldReturn` False
verifyStore dontCheck dontRepair `shouldReturn` False
itRights "check=True repair=False" $
verifyStore True False `shouldReturn` False
verifyStore doCheck dontRepair `shouldReturn` False
--privileged
itRights "check=True repair=True" $
verifyStore True True `shouldReturn` False
verifyStore doCheck doRepair `shouldReturn` False
context "addTextToStore" $
itRights "adds text to store" $ withPath pure
@ -252,7 +252,7 @@ spec_protocol = Hspec.around withNixDaemon $
itRights "adds file to store" $ do
fp <- liftIO $ writeSystemTempFile "addition" "lal"
let name = Data.Either.fromRight (error "impossible") $ makeStorePathName "tmp-addition"
res <- addToStore @SHA256 name (dumpPath fp) False False
res <- addToStore @SHA256 name (dumpPath fp) False dontRepair
liftIO $ print res
context "with dummy" $ do