mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-11-28 14:07:53 +03:00
remote: move flags to Types, wrap in newtype
This commit is contained in:
parent
b1e590606e
commit
c095d12427
@ -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
|
||||
```
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user