remote: port all operations to GADT based ones

This commit is contained in:
sorki 2023-12-07 13:43:52 +01:00
parent ddfdb893a6
commit 523e490137
9 changed files with 281 additions and 470 deletions

View File

@ -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
```

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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 }

View File

@ -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,19 +773,16 @@ 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
then case d of
DerivedPath_Opaque p -> putS storePath p
_ -> throwError
$ SError_NotYetImplemented
"DerivedPath"
"DerivedPath_Built"
(ForPV_Older pv)
else putS derivedPathNew d
}

View File

@ -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 ()

View File

@ -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 <tmp>/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