mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-11-30 02:51:10 +03:00
remote: port all operations to GADT based ones
This commit is contained in:
sorki
parent
ddfdb893a6
commit
523e490137
@ -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
|
||||
```
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 }
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user