From 523e4901379fe6d83e71f1e840df709187f498b5 Mon Sep 17 00:00:00 2001 From: sorki Date: Thu, 7 Dec 2023 13:43:52 +0100 Subject: [PATCH] remote: port all operations to GADT based ones --- hnix-store-remote/README.md | 9 +- hnix-store-remote/hnix-store-remote.cabal | 3 + .../src/System/Nix/Store/Remote.hs | 332 +----------------- .../src/System/Nix/Store/Remote/Client.hs | 258 ++++++++++---- .../src/System/Nix/Store/Remote/Logger.hs | 4 +- .../src/System/Nix/Store/Remote/MonadStore.hs | 34 +- .../src/System/Nix/Store/Remote/Serializer.hs | 25 +- .../Nix/Store/Remote/Types/StoreRequest.hs | 6 +- hnix-store-remote/tests-io/NixDaemon.hs | 80 +++-- 9 files changed, 281 insertions(+), 470 deletions(-) diff --git a/hnix-store-remote/README.md b/hnix-store-remote/README.md index d8fa4d5..cb545cd 100644 --- a/hnix-store-remote/README.md +++ b/hnix-store-remote/README.md @@ -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 ``` diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index c0712e5..a27ae8a 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 3aacb63..cf4b23e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index ff99c3a..820747d 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs index d932432..4e9afa3 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs index edd9cd6..debe4e7 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -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 } 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 0989069..71d8a9a 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -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,20 +773,17 @@ 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 - $ SError_NotYetImplemented - "DerivedPath" - (ForPV_Older pv) + then case d of + DerivedPath_Opaque p -> putS storePath p + _ -> throwError + $ SError_NotYetImplemented + "DerivedPath_Built" + (ForPV_Older pv) else putS derivedPathNew d } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs index 0ebcf32..a375294 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -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 () diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs index ac847bd..4fab4cc 100644 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ b/hnix-store-remote/tests-io/NixDaemon.hs @@ -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 /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