mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +03:00
remote: port all operations to GADT based ones
This commit is contained in:
parent
ddfdb893a6
commit
523e490137
@ -16,6 +16,7 @@ via `nix-daemon`.
|
|||||||
|
|
||||||
import Control.Monad (void)
|
import Control.Monad (void)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
import System.Nix.StorePath (mkStorePathName)
|
||||||
import System.Nix.Store.Remote
|
import System.Nix.Store.Remote
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
@ -25,6 +26,12 @@ main = do
|
|||||||
roots <- findRoots
|
roots <- findRoots
|
||||||
liftIO $ print roots
|
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
|
liftIO $ print res
|
||||||
```
|
```
|
||||||
|
@ -156,6 +156,7 @@ executable remote-readme
|
|||||||
buildable: False
|
buildable: False
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.12 && <5
|
base >=4.12 && <5
|
||||||
|
, hnix-store-core
|
||||||
, hnix-store-remote
|
, hnix-store-remote
|
||||||
build-tool-depends:
|
build-tool-depends:
|
||||||
markdown-unlit:markdown-unlit
|
markdown-unlit:markdown-unlit
|
||||||
@ -212,6 +213,7 @@ test-suite remote-io
|
|||||||
, hnix-store-core
|
, hnix-store-core
|
||||||
, hnix-store-nar
|
, hnix-store-nar
|
||||||
, hnix-store-remote
|
, hnix-store-remote
|
||||||
|
, hnix-store-tests
|
||||||
, bytestring
|
, bytestring
|
||||||
, containers
|
, containers
|
||||||
, crypton
|
, crypton
|
||||||
@ -221,6 +223,7 @@ test-suite remote-io
|
|||||||
, hspec-expectations-lifted
|
, hspec-expectations-lifted
|
||||||
, linux-namespaces
|
, linux-namespaces
|
||||||
, process
|
, process
|
||||||
|
, some
|
||||||
, tasty
|
, tasty
|
||||||
, tasty-hspec
|
, tasty-hspec
|
||||||
, temporary
|
, temporary
|
||||||
|
@ -1,34 +1,6 @@
|
|||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
||||||
{-# LANGUAGE LiberalTypeSynonyms #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module System.Nix.Store.Remote
|
module System.Nix.Store.Remote
|
||||||
(
|
(
|
||||||
-- * Operations
|
module System.Nix.Store.Types
|
||||||
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.Remote.Client
|
, module System.Nix.Store.Remote.Client
|
||||||
, module System.Nix.Store.Remote.MonadStore
|
, module System.Nix.Store.Remote.MonadStore
|
||||||
, module System.Nix.Store.Remote.Types
|
, module System.Nix.Store.Remote.Types
|
||||||
@ -40,43 +12,16 @@ module System.Nix.Store.Remote
|
|||||||
, runStoreOptsTCP
|
, runStoreOptsTCP
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Crypto.Hash (SHA256)
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.Default.Class (Default(def))
|
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 Network.Socket (Family, SockAddr(SockAddrUnix))
|
||||||
import System.Nix.Nar (NarSource)
|
|
||||||
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
|
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
|
||||||
import System.Nix.Build (BuildMode)
|
import System.Nix.StorePath (StoreDir)
|
||||||
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.Store.Remote.MonadStore (RemoteStoreT, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed))
|
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
|
||||||
import System.Nix.Store.Remote.Client (buildDerivation)
|
|
||||||
import System.Nix.Store.Remote.Socket
|
|
||||||
import System.Nix.Store.Remote.Types
|
import System.Nix.Store.Remote.Types
|
||||||
import System.Nix.Store.Remote.Serialize.Prim
|
|
||||||
|
import qualified Control.Exception
|
||||||
|
import qualified Network.Socket
|
||||||
|
|
||||||
-- * Compat
|
-- * Compat
|
||||||
|
|
||||||
@ -139,268 +84,3 @@ runStoreOpts' sockFamily sockAddr storeRootDir code =
|
|||||||
{ preStoreConfig_socket = soc
|
{ preStoreConfig_socket = soc
|
||||||
, preStoreConfig_dir = storeRootDir
|
, 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
|
module System.Nix.Store.Remote.Client
|
||||||
( simpleOp
|
( addToStore
|
||||||
, simpleOpArgs
|
, addTextToStore
|
||||||
, runOp
|
, addSignatures
|
||||||
, runOpArgs
|
, addTempRoot
|
||||||
, runOpArgsIO
|
, addIndirectRoot
|
||||||
, addToStore
|
, buildPaths
|
||||||
, buildDerivation
|
, buildDerivation
|
||||||
|
, collectGarbage
|
||||||
|
, ensurePath
|
||||||
|
, findRoots
|
||||||
, isValidPath
|
, isValidPath
|
||||||
|
, queryValidPaths
|
||||||
|
, queryAllValidPaths
|
||||||
|
, querySubstitutablePaths
|
||||||
|
, queryPathInfo
|
||||||
|
, queryReferrers
|
||||||
|
, queryValidDerivers
|
||||||
|
, queryDerivationOutputs
|
||||||
|
, queryDerivationOutputNames
|
||||||
|
, queryPathFromHashPart
|
||||||
|
, queryMissing
|
||||||
|
, optimiseStore
|
||||||
|
, syncWithGC
|
||||||
|
, verifyStore
|
||||||
, module System.Nix.Store.Remote.Client.Core
|
, module System.Nix.Store.Remote.Client.Core
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
import Control.Monad.Except (throwError)
|
import Control.Monad.Except (throwError)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Data.HashSet (HashSet)
|
||||||
import Data.Serialize.Put (Put, runPut)
|
import Data.Map (Map)
|
||||||
|
import Data.Set (Set)
|
||||||
import Data.Some (Some)
|
import Data.Some (Some)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
|
||||||
import System.Nix.Build (BuildMode, BuildResult)
|
import System.Nix.Build (BuildMode, BuildResult)
|
||||||
import System.Nix.Derivation (Derivation)
|
import System.Nix.Derivation (Derivation)
|
||||||
|
import System.Nix.DerivedPath (DerivedPath)
|
||||||
import System.Nix.Hash (HashAlgo(..))
|
import System.Nix.Hash (HashAlgo(..))
|
||||||
import System.Nix.Nar (NarSource)
|
import System.Nix.Nar (NarSource)
|
||||||
import System.Nix.StorePath (StorePath, StorePathName)
|
import System.Nix.Signature (Signature)
|
||||||
import System.Nix.Store.Remote.Logger (processOutput)
|
import System.Nix.StorePath (StorePath, StorePathHashPart, StorePathName)
|
||||||
|
import System.Nix.StorePath.Metadata (Metadata)
|
||||||
import System.Nix.Store.Remote.MonadStore
|
import System.Nix.Store.Remote.MonadStore
|
||||||
import System.Nix.Store.Remote.Socket (sockPutS, sockGetS)
|
import System.Nix.Store.Remote.Types.GC (GCOptions, GCResult, GCRoot)
|
||||||
import System.Nix.Store.Remote.Serializer (bool, enum, mapErrorS)
|
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.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.Remote.Client.Core
|
||||||
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
|
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
|
-- | Add `NarSource` to the store
|
||||||
addToStore
|
addToStore
|
||||||
:: MonadRemoteStore m
|
:: MonadRemoteStore m
|
||||||
@ -100,6 +69,48 @@ addToStore name source method hashAlgo repair = do
|
|||||||
setNarSource source
|
setNarSource source
|
||||||
doReq (AddToStore name method hashAlgo repair)
|
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
|
buildDerivation
|
||||||
:: MonadRemoteStore m
|
:: MonadRemoteStore m
|
||||||
=> StorePath
|
=> StorePath
|
||||||
@ -108,5 +119,120 @@ buildDerivation
|
|||||||
-> m BuildResult
|
-> m BuildResult
|
||||||
buildDerivation a b c = doReq (BuildDerivation a b c)
|
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
|
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 Data.Serialize (Result(..))
|
||||||
import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT)
|
import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT)
|
||||||
import System.Nix.Store.Remote.Socket (sockGet8)
|
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.Logger (Logger(..))
|
||||||
import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion)
|
import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion)
|
||||||
|
|
||||||
@ -52,7 +52,7 @@ processOutput = do
|
|||||||
Right ctrl -> do
|
Right ctrl -> do
|
||||||
case ctrl of
|
case ctrl of
|
||||||
-- These two terminate the logger loop
|
-- These two terminate the logger loop
|
||||||
e@(Logger_Error _) -> setError >> appendLog e
|
Logger_Error e -> throwError $ RemoteStoreError_LoggerError e
|
||||||
Logger_Last -> appendLog Logger_Last
|
Logger_Last -> appendLog Logger_Last
|
||||||
|
|
||||||
-- Read data from source
|
-- Read data from source
|
||||||
|
@ -30,7 +30,7 @@ import Network.Socket (Socket)
|
|||||||
import System.Nix.Nar (NarSource)
|
import System.Nix.Nar (NarSource)
|
||||||
import System.Nix.StorePath (HasStoreDir(..), StoreDir)
|
import System.Nix.StorePath (HasStoreDir(..), StoreDir)
|
||||||
import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, ReplySError, SError)
|
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.ProtoVersion (HasProtoVersion(..), ProtoVersion)
|
||||||
import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig)
|
import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig)
|
||||||
|
|
||||||
@ -66,6 +66,7 @@ data RemoteStoreError
|
|||||||
| RemoteStoreError_SerializerRequest RequestSError
|
| RemoteStoreError_SerializerRequest RequestSError
|
||||||
| RemoteStoreError_SerializerReply ReplySError
|
| RemoteStoreError_SerializerReply ReplySError
|
||||||
| RemoteStoreError_IOException SomeException
|
| 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_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_LoggerParserFail String ByteString -- when incremental parser returns ((Fail msg leftover) :: Result)
|
||||||
| RemoteStoreError_NoDataSourceProvided -- remoteStoreState_mDataSource is required but it is Nothing
|
| RemoteStoreError_NoDataSourceProvided -- remoteStoreState_mDataSource is required but it is Nothing
|
||||||
@ -171,33 +172,6 @@ class ( MonadIO m
|
|||||||
-> m ()
|
-> m ()
|
||||||
appendLog = lift . appendLog
|
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
|
getStoreDir :: m StoreDir
|
||||||
default getStoreDir
|
default getStoreDir
|
||||||
:: ( MonadTrans t
|
:: ( MonadTrans t
|
||||||
@ -311,10 +285,6 @@ instance ( MonadIO m
|
|||||||
$ modify
|
$ modify
|
||||||
$ \s -> s { remoteStoreState_logs = remoteStoreState_logs s `Data.DList.snoc` x }
|
$ \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 }
|
setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = pure x }
|
||||||
getDataSource = remoteStoreState_mDataSource <$> RemoteStoreT get
|
getDataSource = remoteStoreState_mDataSource <$> RemoteStoreT get
|
||||||
clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = Nothing }
|
clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = Nothing }
|
||||||
|
@ -144,11 +144,11 @@ import qualified Data.Time.Clock.POSIX
|
|||||||
import qualified Data.Vector
|
import qualified Data.Vector
|
||||||
|
|
||||||
import Data.Serializer
|
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.Build (BuildMode, BuildResult(..))
|
||||||
import System.Nix.ContentAddress (ContentAddress)
|
import System.Nix.ContentAddress (ContentAddress)
|
||||||
import System.Nix.Derivation (Derivation(..), DerivationOutput(..))
|
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.Hash (HashAlgo(..))
|
||||||
import System.Nix.JSON ()
|
import System.Nix.JSON ()
|
||||||
import System.Nix.OutputName (OutputName)
|
import System.Nix.OutputName (OutputName)
|
||||||
@ -563,7 +563,7 @@ pathMetadata = Serializer
|
|||||||
{ getS = do
|
{ getS = do
|
||||||
metadataDeriverPath <- getS maybePath
|
metadataDeriverPath <- getS maybePath
|
||||||
|
|
||||||
digest' <- getS $ digest NixBase32
|
digest' <- getS $ digest Base16
|
||||||
let metadataNarHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest'
|
let metadataNarHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest'
|
||||||
|
|
||||||
metadataReferences <- getS $ hashSet storePath
|
metadataReferences <- getS $ hashSet storePath
|
||||||
@ -588,7 +588,7 @@ pathMetadata = Serializer
|
|||||||
-> SerialT r SError PutM ()
|
-> SerialT r SError PutM ()
|
||||||
putNarHash = \case
|
putNarHash = \case
|
||||||
System.Nix.Hash.HashAlgo_SHA256 :=> d
|
System.Nix.Hash.HashAlgo_SHA256 :=> d
|
||||||
-> putS (digest @SHA256 NixBase32) d
|
-> putS (digest @SHA256 Base16) d
|
||||||
_ -> throwError SError_NarHashMustBeSHA256
|
_ -> throwError SError_NarHashMustBeSHA256
|
||||||
|
|
||||||
putNarHash metadataNarHash
|
putNarHash metadataNarHash
|
||||||
@ -773,20 +773,17 @@ derivedPath = Serializer
|
|||||||
{ getS = do
|
{ getS = do
|
||||||
pv <- Control.Monad.Reader.asks hasProtoVersion
|
pv <- Control.Monad.Reader.asks hasProtoVersion
|
||||||
if pv < ProtoVersion 1 30
|
if pv < ProtoVersion 1 30
|
||||||
then
|
then DerivedPath_Opaque <$> getS storePath
|
||||||
throwError
|
|
||||||
$ SError_NotYetImplemented
|
|
||||||
"DerivedPath"
|
|
||||||
(ForPV_Older pv)
|
|
||||||
else getS derivedPathNew
|
else getS derivedPathNew
|
||||||
, putS = \d -> do
|
, putS = \d -> do
|
||||||
pv <- Control.Monad.Reader.asks hasProtoVersion
|
pv <- Control.Monad.Reader.asks hasProtoVersion
|
||||||
if pv < ProtoVersion 1 30
|
if pv < ProtoVersion 1 30
|
||||||
then
|
then case d of
|
||||||
throwError
|
DerivedPath_Opaque p -> putS storePath p
|
||||||
$ SError_NotYetImplemented
|
_ -> throwError
|
||||||
"DerivedPath"
|
$ SError_NotYetImplemented
|
||||||
(ForPV_Older pv)
|
"DerivedPath_Built"
|
||||||
|
(ForPV_Older pv)
|
||||||
else putS derivedPathNew d
|
else putS derivedPathNew d
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -53,13 +53,13 @@ data StoreRequest :: Type -> Type where
|
|||||||
-> Set Signature
|
-> Set Signature
|
||||||
-> StoreRequest ()
|
-> StoreRequest ()
|
||||||
|
|
||||||
-- | Add temporary garbage collector root.
|
|
||||||
--
|
|
||||||
-- This root is removed as soon as the client exits.
|
|
||||||
AddIndirectRoot
|
AddIndirectRoot
|
||||||
:: StorePath
|
:: StorePath
|
||||||
-> StoreRequest ()
|
-> StoreRequest ()
|
||||||
|
|
||||||
|
-- | Add temporary garbage collector root.
|
||||||
|
--
|
||||||
|
-- This root is removed as soon as the client exits.
|
||||||
AddTempRoot
|
AddTempRoot
|
||||||
:: StorePath
|
:: StorePath
|
||||||
-> StoreRequest ()
|
-> StoreRequest ()
|
||||||
|
@ -2,9 +2,10 @@
|
|||||||
|
|
||||||
module NixDaemon where
|
module NixDaemon where
|
||||||
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Either (isRight, isLeft)
|
import Data.Either (isRight, isLeft)
|
||||||
import Data.Bool (bool)
|
import Data.Bool (bool)
|
||||||
|
import Data.Some (Some(Some))
|
||||||
|
import Data.Text (Text)
|
||||||
import Control.Monad (forM_, void)
|
import Control.Monad (forM_, void)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import qualified System.Environment
|
import qualified System.Environment
|
||||||
@ -14,6 +15,7 @@ import qualified Data.ByteString.Char8 as BSC
|
|||||||
import qualified Data.Either
|
import qualified Data.Either
|
||||||
import qualified Data.HashSet as HS
|
import qualified Data.HashSet as HS
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
|
import qualified Data.Set
|
||||||
import qualified Data.Text
|
import qualified Data.Text
|
||||||
import qualified Data.Text.Encoding
|
import qualified Data.Text.Encoding
|
||||||
import System.Directory
|
import System.Directory
|
||||||
@ -24,8 +26,11 @@ import System.Linux.Namespaces as NS
|
|||||||
import Test.Hspec (Spec, describe, context)
|
import Test.Hspec (Spec, describe, context)
|
||||||
import qualified Test.Hspec as Hspec
|
import qualified Test.Hspec as Hspec
|
||||||
import Test.Hspec.Expectations.Lifted
|
import Test.Hspec.Expectations.Lifted
|
||||||
|
import Test.Hspec.Nix (forceRight)
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
import System.Nix.Hash (HashAlgo(HashAlgo_SHA256))
|
||||||
import System.Nix.Build
|
import System.Nix.Build
|
||||||
|
import System.Nix.DerivedPath (DerivedPath(..))
|
||||||
import System.Nix.StorePath
|
import System.Nix.StorePath
|
||||||
import System.Nix.StorePath.Metadata
|
import System.Nix.StorePath.Metadata
|
||||||
import System.Nix.Store.Remote
|
import System.Nix.Store.Remote
|
||||||
@ -156,14 +161,25 @@ itLefts name action = it name action isLeft
|
|||||||
|
|
||||||
withPath :: (StorePath -> MonadStore a) -> MonadStore a
|
withPath :: (StorePath -> MonadStore a) -> MonadStore a
|
||||||
withPath action = do
|
withPath action = do
|
||||||
path <- addTextToStore "hnix-store" "test" mempty RepairMode_DontRepair
|
path <-
|
||||||
|
addTextToStore
|
||||||
|
(StoreText
|
||||||
|
(forceRight $ mkStorePathName "hnix-store")
|
||||||
|
"test"
|
||||||
|
)
|
||||||
|
mempty
|
||||||
|
RepairMode_DontRepair
|
||||||
action path
|
action path
|
||||||
|
|
||||||
-- | dummy path, adds <tmp>/dummy with "Hello World" contents
|
-- | dummy path, adds <tmp>/dummy with "Hello World" contents
|
||||||
dummy :: MonadStore StorePath
|
dummy :: MonadStore StorePath
|
||||||
dummy = do
|
dummy = do
|
||||||
let name = Data.Either.fromRight (error "impossible") $ mkStorePathName "dummy"
|
addToStore
|
||||||
addToStore @SHA256 name (dumpPath "dummy") FileIngestionMethod_Flat RepairMode_DontRepair
|
(forceRight $ mkStorePathName "dummy")
|
||||||
|
(dumpPath "dummy")
|
||||||
|
FileIngestionMethod_Flat
|
||||||
|
(Some HashAlgo_SHA256)
|
||||||
|
RepairMode_DontRepair
|
||||||
|
|
||||||
invalidPath :: StorePath
|
invalidPath :: StorePath
|
||||||
invalidPath =
|
invalidPath =
|
||||||
@ -172,7 +188,11 @@ invalidPath =
|
|||||||
|
|
||||||
withBuilder :: (StorePath -> MonadStore a) -> MonadStore a
|
withBuilder :: (StorePath -> MonadStore a) -> MonadStore a
|
||||||
withBuilder action = do
|
withBuilder action = do
|
||||||
path <- addTextToStore "builder" builderSh mempty RepairMode_DontRepair
|
path <-
|
||||||
|
addTextToStore
|
||||||
|
(StoreText (forceRight $ mkStorePathName "builder") builderSh)
|
||||||
|
mempty
|
||||||
|
RepairMode_DontRepair
|
||||||
action path
|
action path
|
||||||
|
|
||||||
builderSh :: Text
|
builderSh :: Text
|
||||||
@ -209,24 +229,24 @@ spec_protocol = Hspec.around withNixDaemon $
|
|||||||
context "addTextToStore" $
|
context "addTextToStore" $
|
||||||
itRights "adds text to store" $ withPath pure
|
itRights "adds text to store" $ withPath pure
|
||||||
|
|
||||||
context "isValidPathUncached" $ do
|
context "isValidPath" $ do
|
||||||
itRights "validates path" $ withPath $ \path -> do
|
itRights "validates path" $ withPath $ \path -> do
|
||||||
liftIO $ print path
|
liftIO $ print path
|
||||||
isValidPathUncached path `shouldReturn` True
|
isValidPath path `shouldReturn` True
|
||||||
itLefts "fails on invalid path"
|
itLefts "fails on invalid path"
|
||||||
$ mapStoreConfig
|
$ mapStoreConfig
|
||||||
(\sc -> sc { storeConfig_dir = StoreDir "/asdf" })
|
(\sc -> sc { storeConfig_dir = StoreDir "/asdf" })
|
||||||
$ isValidPathUncached invalidPath
|
$ isValidPath invalidPath
|
||||||
|
|
||||||
context "queryAllValidPaths" $ do
|
context "queryAllValidPaths" $ do
|
||||||
itRights "empty query" queryAllValidPaths
|
itRights "empty query" queryAllValidPaths
|
||||||
itRights "non-empty query" $ withPath $ \path ->
|
itRights "non-empty query" $ withPath $ \path ->
|
||||||
queryAllValidPaths `shouldReturn` HS.fromList [path]
|
queryAllValidPaths `shouldReturn` HS.fromList [path]
|
||||||
|
|
||||||
context "queryPathInfoUncached" $
|
context "queryPathInfo" $
|
||||||
itRights "queries path info" $ withPath $ \path -> do
|
itRights "queries path info" $ withPath $ \path -> do
|
||||||
meta <- queryPathInfoUncached path
|
meta <- queryPathInfo path
|
||||||
metadataReferences meta `shouldSatisfy` HS.null
|
(metadataReferences <$> meta) `shouldBe` (Just mempty)
|
||||||
|
|
||||||
context "ensurePath" $
|
context "ensurePath" $
|
||||||
itRights "simple ensure" $ withPath ensurePath
|
itRights "simple ensure" $ withPath ensurePath
|
||||||
@ -237,18 +257,17 @@ spec_protocol = Hspec.around withNixDaemon $
|
|||||||
context "addIndirectRoot" $
|
context "addIndirectRoot" $
|
||||||
itRights "simple addition" $ withPath addIndirectRoot
|
itRights "simple addition" $ withPath addIndirectRoot
|
||||||
|
|
||||||
|
let toDerivedPathSet p = Data.Set.fromList [DerivedPath_Opaque p]
|
||||||
|
|
||||||
context "buildPaths" $ do
|
context "buildPaths" $ do
|
||||||
itRights "build Normal" $ withPath $ \path -> do
|
itRights "build Normal" $ withPath $ \path -> do
|
||||||
let pathSet = HS.fromList [path]
|
buildPaths (toDerivedPathSet path) BuildMode_Normal
|
||||||
buildPaths pathSet BuildMode_Normal
|
|
||||||
|
|
||||||
itRights "build Check" $ withPath $ \path -> do
|
itRights "build Check" $ withPath $ \path -> do
|
||||||
let pathSet = HS.fromList [path]
|
buildPaths (toDerivedPathSet path) BuildMode_Check
|
||||||
buildPaths pathSet BuildMode_Check
|
|
||||||
|
|
||||||
itLefts "build Repair" $ withPath $ \path -> do
|
itLefts "build Repair" $ withPath $ \path -> do
|
||||||
let pathSet = HS.fromList [path]
|
buildPaths (toDerivedPathSet path) BuildMode_Repair
|
||||||
buildPaths pathSet BuildMode_Repair
|
|
||||||
|
|
||||||
context "roots" $ context "findRoots" $ do
|
context "roots" $ context "findRoots" $ do
|
||||||
itRights "empty roots" (findRoots `shouldReturn` M.empty)
|
itRights "empty roots" (findRoots `shouldReturn` M.empty)
|
||||||
@ -261,8 +280,7 @@ spec_protocol = Hspec.around withNixDaemon $
|
|||||||
|
|
||||||
context "queryMissing" $
|
context "queryMissing" $
|
||||||
itRights "queries" $ withPath $ \path -> do
|
itRights "queries" $ withPath $ \path -> do
|
||||||
let pathSet = HS.fromList [path]
|
queryMissing (toDerivedPathSet path)
|
||||||
queryMissing pathSet
|
|
||||||
`shouldReturn`
|
`shouldReturn`
|
||||||
Missing
|
Missing
|
||||||
{ missingWillBuild = mempty
|
{ missingWillBuild = mempty
|
||||||
@ -275,9 +293,12 @@ spec_protocol = Hspec.around withNixDaemon $
|
|||||||
context "addToStore" $
|
context "addToStore" $
|
||||||
itRights "adds file to store" $ do
|
itRights "adds file to store" $ do
|
||||||
fp <- liftIO $ writeSystemTempFile "addition" "lal"
|
fp <- liftIO $ writeSystemTempFile "addition" "lal"
|
||||||
let name = Data.Either.fromRight (error "impossible") $ mkStorePathName "tmp-addition"
|
addToStore
|
||||||
res <- addToStore @SHA256 name (dumpPath fp) FileIngestionMethod_Flat RepairMode_DontRepair
|
(forceRight $ mkStorePathName "tmp-addition")
|
||||||
liftIO $ print res
|
(dumpPath fp)
|
||||||
|
FileIngestionMethod_Flat
|
||||||
|
(Some HashAlgo_SHA256)
|
||||||
|
RepairMode_DontRepair
|
||||||
|
|
||||||
context "with dummy" $ do
|
context "with dummy" $ do
|
||||||
itRights "adds dummy" dummy
|
itRights "adds dummy" dummy
|
||||||
@ -285,10 +306,10 @@ spec_protocol = Hspec.around withNixDaemon $
|
|||||||
itRights "valid dummy" $ do
|
itRights "valid dummy" $ do
|
||||||
path <- dummy
|
path <- dummy
|
||||||
liftIO $ print path
|
liftIO $ print path
|
||||||
isValidPathUncached path `shouldReturn` True
|
isValidPath path `shouldReturn` True
|
||||||
|
|
||||||
context "deleteSpecific" $
|
context "collectGarbage" $ do
|
||||||
itRights "delete a path from the store" $ withPath $ \path -> 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...
|
-- clear temp gc roots so the delete works. restarting the nix daemon should also do this...
|
||||||
storeDir <- getStoreDir
|
storeDir <- getStoreDir
|
||||||
let tempRootsDir = Data.Text.unpack $ mconcat [ Data.Text.Encoding.decodeUtf8 (unStoreDir storeDir), "/../var/nix/temproots/" ]
|
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
|
liftIO $ forM_ tempRootList $ \entry -> do
|
||||||
removeFile $ mconcat [ tempRootsDir, "/", entry ]
|
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]
|
gcResultDeletedPaths `shouldBe` HS.fromList [path]
|
||||||
gcResultBytesFreed `shouldBe` 4
|
gcResultBytesFreed `shouldBe` 4
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user