mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-08-17 13:51:21 +03:00
commit
11da925989
@ -4,6 +4,7 @@ benchmarks: true
|
||||
packages:
|
||||
./hnix-store-core/hnix-store-core.cabal
|
||||
./hnix-store-db/hnix-store-db.cabal
|
||||
./hnix-store-json/hnix-store-json.cabal
|
||||
./hnix-store-nar/hnix-store-nar.cabal
|
||||
./hnix-store-readonly/hnix-store-readonly.cabal
|
||||
./hnix-store-remote/hnix-store-remote.cabal
|
||||
|
@ -4,6 +4,9 @@ package hnix-store-core
|
||||
package hnix-store-db
|
||||
ghc-options: -Wunused-packages -Wall -Werror
|
||||
|
||||
package hnix-store-json
|
||||
ghc-options: -Wunused-packages -Wall -Werror
|
||||
|
||||
package hnix-store-nar
|
||||
ghc-options: -Wunused-packages -Wall -Werror
|
||||
|
||||
|
@ -22,6 +22,7 @@ in {
|
||||
inherit (haskellPackages)
|
||||
hnix-store-core
|
||||
hnix-store-db
|
||||
hnix-store-json
|
||||
hnix-store-nar
|
||||
hnix-store-readonly
|
||||
hnix-store-remote
|
||||
|
@ -28,3 +28,6 @@ in order of appearance:
|
||||
+ Luigy Leon @luigy
|
||||
+ squalus @squalus
|
||||
+ Vaibhav Sagar @vaibhavsagar
|
||||
+ Ryan Trinkle @ryantrinkle
|
||||
+ Travis Whitaker @TravisWhitaker
|
||||
+ Andrea Bedini @andreabedini
|
||||
|
6
hie.yaml
6
hie.yaml
@ -12,6 +12,12 @@ cradle:
|
||||
- path: "./hnix-store-db/tests"
|
||||
component: "hnix-store-db:test:db"
|
||||
|
||||
- path: "./hnix-store-json/src"
|
||||
component: "lib:hnix-store-json"
|
||||
|
||||
- path: "./hnix-store-json/tests"
|
||||
component: "hnix-store-json:test:json"
|
||||
|
||||
- path: "./hnix-store-nar/src"
|
||||
component: "lib:hnix-store-nar"
|
||||
|
||||
|
@ -1,6 +1,7 @@
|
||||
# Next
|
||||
|
||||
* Changes:
|
||||
* `System.Nix.StorePath.makeStorePathName` renamed to `System.Nix.StorePath.mkStorePathName`
|
||||
* `System.Nix.ReadOnlyStore` moved to `hnix-store-readonly` package
|
||||
and renamed to `System.Nix.Store.ReadOnly` [#247](https://github.com/haskell-nix/hnix-store/pull/247)
|
||||
* `System.Nix.Nar*` moved to `hnix-store-nar` package [#247](https://github.com/haskell-nix/hnix-store/pull/247)
|
||||
|
@ -65,6 +65,8 @@ library
|
||||
, System.Nix.Fingerprint
|
||||
, System.Nix.Hash
|
||||
, System.Nix.Hash.Truncation
|
||||
, System.Nix.OutputName
|
||||
, System.Nix.Realisation
|
||||
, System.Nix.Signature
|
||||
, System.Nix.Store.Types
|
||||
, System.Nix.StorePath
|
||||
@ -80,7 +82,7 @@ library
|
||||
, crypton
|
||||
, data-default-class
|
||||
, dependent-sum > 0.7
|
||||
, dependent-sum-template > 0.1.1 && < 0.3
|
||||
, dependent-sum-template >= 0.2.0.1 && < 0.3
|
||||
, filepath
|
||||
, hashable
|
||||
-- Required for crypton low-level type convertion
|
||||
@ -102,6 +104,7 @@ test-suite core
|
||||
Fingerprint
|
||||
Hash
|
||||
Signature
|
||||
StorePath
|
||||
hs-source-dirs:
|
||||
tests
|
||||
build-tool-depends:
|
||||
|
@ -5,34 +5,40 @@ Maintainer : srk <srk@48.io>
|
||||
module System.Nix.Build
|
||||
( BuildMode(..)
|
||||
, BuildStatus(..)
|
||||
, BuildResult(..)
|
||||
, buildSuccess
|
||||
, BuildResult(..)
|
||||
) where
|
||||
|
||||
import Data.Map (Map)
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
-- keep the order of these Enums to match enums from reference implementations
|
||||
import System.Nix.OutputName (OutputName)
|
||||
import System.Nix.Realisation (DerivationOutput, Realisation)
|
||||
|
||||
-- | Mode of the build operation
|
||||
-- Keep the order of these Enums to match enums from reference implementations
|
||||
-- src/libstore/store-api.hh
|
||||
data BuildMode
|
||||
= BuildMode_Normal
|
||||
| BuildMode_Repair
|
||||
| BuildMode_Check
|
||||
= BuildMode_Normal -- ^ Perform normal build
|
||||
| BuildMode_Repair -- ^ Try to repair corrupted or missing paths by re-building or re-downloading them
|
||||
| BuildMode_Check -- ^ Check if the build is reproducible (rebuild and compare to previous build)
|
||||
deriving (Eq, Generic, Ord, Enum, Show)
|
||||
|
||||
-- | Build result status
|
||||
data BuildStatus =
|
||||
BuildStatus_Built
|
||||
| BuildStatus_Substituted
|
||||
| BuildStatus_AlreadyValid
|
||||
BuildStatus_Built -- ^ Build performed successfully
|
||||
| BuildStatus_Substituted -- ^ Path substituted from cache
|
||||
| BuildStatus_AlreadyValid -- ^ Path is already valid (available in local store)
|
||||
| BuildStatus_PermanentFailure
|
||||
| BuildStatus_InputRejected
|
||||
| BuildStatus_OutputRejected
|
||||
| BuildStatus_TransientFailure -- possibly transient
|
||||
| BuildStatus_CachedFailure -- no longer used
|
||||
| BuildStatus_TimedOut
|
||||
| BuildStatus_TransientFailure -- ^ Possibly transient build failure
|
||||
| BuildStatus_CachedFailure -- ^ Obsolete
|
||||
| BuildStatus_TimedOut -- ^ Build timed out
|
||||
| BuildStatus_MiscFailure
|
||||
| BuildStatus_DependencyFailed
|
||||
| BuildStatus_DependencyFailed -- ^ Build dependency failed to build
|
||||
| BuildStatus_LogLimitExceeded
|
||||
| BuildStatus_NotDeterministic
|
||||
| BuildStatus_ResolvesToAlreadyValid
|
||||
@ -41,24 +47,27 @@ data BuildStatus =
|
||||
|
||||
-- | Result of the build
|
||||
data BuildResult = BuildResult
|
||||
{ -- | build status, MiscFailure should be default
|
||||
status :: !BuildStatus
|
||||
, -- | possible build error message
|
||||
errorMessage :: !(Maybe Text)
|
||||
, -- | How many times this build was performed
|
||||
timesBuilt :: !Int
|
||||
, -- | If timesBuilt > 1, whether some builds did not produce the same result
|
||||
isNonDeterministic :: !Bool
|
||||
, -- Start time of this build
|
||||
startTime :: !UTCTime
|
||||
, -- Stop time of this build
|
||||
stopTime :: !UTCTime
|
||||
{ buildResultStatus :: BuildStatus
|
||||
-- ^ Build status, MiscFailure should be the default
|
||||
, buildResultErrorMessage :: Maybe Text
|
||||
-- ^ Possible build error message
|
||||
, buildResultTimesBuilt :: Maybe Int
|
||||
-- ^ How many times this build was performed (since 1.29)
|
||||
, buildResultIsNonDeterministic :: Maybe Bool
|
||||
-- ^ If timesBuilt > 1, whether some builds did not produce the same result (since 1.29)
|
||||
, buildResultStartTime :: Maybe UTCTime
|
||||
-- ^ Start time of this build (since 1.29)
|
||||
, buildResultStopTime :: Maybe UTCTime
|
||||
-- ^ Stop time of this build (since 1.29)
|
||||
, buildResultBuiltOutputs :: Maybe (Map (DerivationOutput OutputName) Realisation)
|
||||
-- ^ Mapping of the output names to @Realisation@s (since 1.28)
|
||||
-- (paths with additional info and their dependencies)
|
||||
}
|
||||
deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
buildSuccess :: BuildResult -> Bool
|
||||
buildSuccess BuildResult {..} =
|
||||
status `elem`
|
||||
buildSuccess :: BuildStatus -> Bool
|
||||
buildSuccess x =
|
||||
x `elem`
|
||||
[ BuildStatus_Built
|
||||
, BuildStatus_Substituted
|
||||
, BuildStatus_AlreadyValid
|
||||
|
@ -10,19 +10,22 @@ module System.Nix.DerivedPath (
|
||||
, derivedPathToText
|
||||
) where
|
||||
|
||||
import Data.Bifunctor (first)
|
||||
import GHC.Generics (Generic)
|
||||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
import System.Nix.StorePath (StoreDir, StorePath, StorePathName, InvalidPathError)
|
||||
import System.Nix.OutputName (OutputName, InvalidNameError)
|
||||
import System.Nix.StorePath (StoreDir(..), StorePath, InvalidPathError)
|
||||
|
||||
import qualified Data.Bifunctor
|
||||
import qualified Data.ByteString.Char8
|
||||
import qualified Data.Set
|
||||
import qualified Data.Text
|
||||
import qualified System.Nix.OutputName
|
||||
import qualified System.Nix.StorePath
|
||||
|
||||
data OutputsSpec =
|
||||
OutputsSpec_All
|
||||
| OutputsSpec_Names (Set StorePathName)
|
||||
| OutputsSpec_Names (Set OutputName)
|
||||
deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
data DerivedPath =
|
||||
@ -32,20 +35,20 @@ data DerivedPath =
|
||||
|
||||
data ParseOutputsError =
|
||||
ParseOutputsError_InvalidPath InvalidPathError
|
||||
| ParseOutputsError_InvalidName InvalidNameError
|
||||
| ParseOutputsError_NoNames
|
||||
| ParseOutputsError_NoPrefix StoreDir Text
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
convertError
|
||||
:: Either InvalidPathError a
|
||||
-> Either ParseOutputsError a
|
||||
convertError = first ParseOutputsError_InvalidPath
|
||||
|
||||
parseOutputsSpec :: Text -> Either ParseOutputsError OutputsSpec
|
||||
parseOutputsSpec t
|
||||
| t == "*" = Right OutputsSpec_All
|
||||
| otherwise = do
|
||||
names <- mapM
|
||||
(convertError . System.Nix.StorePath.makeStorePathName)
|
||||
( Data.Bifunctor.first
|
||||
ParseOutputsError_InvalidName
|
||||
. System.Nix.OutputName.mkOutputName
|
||||
)
|
||||
(Data.Text.splitOn "," t)
|
||||
if null names
|
||||
then Left ParseOutputsError_NoNames
|
||||
@ -55,21 +58,47 @@ outputsSpecToText :: OutputsSpec -> Text
|
||||
outputsSpecToText = \case
|
||||
OutputsSpec_All -> "*"
|
||||
OutputsSpec_Names ns ->
|
||||
Data.Text.intercalate "," (fmap System.Nix.StorePath.unStorePathName (Data.Set.toList ns))
|
||||
Data.Text.intercalate
|
||||
","
|
||||
(fmap System.Nix.OutputName.unOutputName
|
||||
(Data.Set.toList ns)
|
||||
)
|
||||
|
||||
parseDerivedPath
|
||||
:: StoreDir
|
||||
-> Text
|
||||
-> Either ParseOutputsError DerivedPath
|
||||
parseDerivedPath root p =
|
||||
case Data.Text.breakOn "!" p of
|
||||
(s, r) ->
|
||||
if Data.Text.null r
|
||||
then DerivedPath_Opaque
|
||||
<$> (convertError $ System.Nix.StorePath.parsePathFromText root s)
|
||||
else DerivedPath_Built
|
||||
<$> (convertError $ System.Nix.StorePath.parsePathFromText root s)
|
||||
<*> parseOutputsSpec (Data.Text.drop (Data.Text.length "!") r)
|
||||
parseDerivedPath root@(StoreDir sd) path =
|
||||
let -- We need to do a bit more legwork for case
|
||||
-- when StoreDir contains '!'
|
||||
-- which is generated by its Arbitrary instance
|
||||
textRoot = Data.Text.pack
|
||||
$ Data.ByteString.Char8.unpack sd
|
||||
|
||||
in case Data.Text.stripPrefix textRoot path of
|
||||
Nothing -> Left $ ParseOutputsError_NoPrefix root path
|
||||
Just woRoot ->
|
||||
case Data.Text.breakOn "!" woRoot of
|
||||
(pathNoPrefix, r) ->
|
||||
if Data.Text.null r
|
||||
then DerivedPath_Opaque
|
||||
<$> (convertError
|
||||
$ System.Nix.StorePath.parsePathFromText
|
||||
root
|
||||
path
|
||||
)
|
||||
else DerivedPath_Built
|
||||
<$> (convertError
|
||||
$ System.Nix.StorePath.parsePathFromText
|
||||
root
|
||||
(textRoot <> pathNoPrefix)
|
||||
)
|
||||
<*> parseOutputsSpec (Data.Text.drop (Data.Text.length "!") r)
|
||||
where
|
||||
convertError
|
||||
:: Either InvalidPathError a
|
||||
-> Either ParseOutputsError a
|
||||
convertError = Data.Bifunctor.first ParseOutputsError_InvalidPath
|
||||
|
||||
derivedPathToText :: StoreDir -> DerivedPath -> Text
|
||||
derivedPathToText root = \case
|
||||
|
@ -26,8 +26,13 @@ import qualified Data.Text as Text
|
||||
-- | Produce the message signed by a NAR signature
|
||||
metadataFingerprint :: StoreDir -> StorePath -> Metadata StorePath -> Text
|
||||
metadataFingerprint storeDir storePath Metadata{..} = let
|
||||
narSize = fromMaybe 0 narBytes
|
||||
in fingerprint storeDir storePath narHash narSize (HashSet.toList references)
|
||||
narSize = fromMaybe 0 metadataNarBytes
|
||||
in fingerprint
|
||||
storeDir
|
||||
storePath
|
||||
metadataNarHash
|
||||
narSize
|
||||
(HashSet.toList metadataReferences)
|
||||
|
||||
-- | Produce the message signed by a NAR signature
|
||||
fingerprint :: StoreDir
|
||||
|
29
hnix-store-core/src/System/Nix/OutputName.hs
Normal file
29
hnix-store-core/src/System/Nix/OutputName.hs
Normal file
@ -0,0 +1,29 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-|
|
||||
Description : Derived path output names
|
||||
-}
|
||||
|
||||
module System.Nix.OutputName
|
||||
( OutputName(..)
|
||||
, mkOutputName
|
||||
-- * Re-exports
|
||||
, System.Nix.StorePath.InvalidNameError(..)
|
||||
, System.Nix.StorePath.parseNameText
|
||||
) where
|
||||
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
import System.Nix.StorePath (InvalidNameError)
|
||||
|
||||
import qualified System.Nix.StorePath
|
||||
|
||||
-- | Name of the derived path output
|
||||
-- Typically used for "dev", "doc" sub-outputs
|
||||
newtype OutputName = OutputName
|
||||
{ -- | Extract the contents of the name.
|
||||
unOutputName :: Text
|
||||
} deriving (Eq, Generic, Hashable, Ord, Show)
|
||||
|
||||
mkOutputName :: Text -> Either InvalidNameError OutputName
|
||||
mkOutputName = fmap OutputName . System.Nix.StorePath.parseNameText
|
92
hnix-store-core/src/System/Nix/Realisation.hs
Normal file
92
hnix-store-core/src/System/Nix/Realisation.hs
Normal file
@ -0,0 +1,92 @@
|
||||
{-|
|
||||
Description : Derivation realisations
|
||||
-}
|
||||
|
||||
module System.Nix.Realisation (
|
||||
DerivationOutput(..)
|
||||
, DerivationOutputError(..)
|
||||
, derivationOutputBuilder
|
||||
, derivationOutputParser
|
||||
, Realisation(..)
|
||||
) where
|
||||
|
||||
import Crypto.Hash (Digest)
|
||||
import Data.Map (Map)
|
||||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Lazy.Builder (Builder)
|
||||
import Data.Dependent.Sum (DSum)
|
||||
import GHC.Generics (Generic)
|
||||
import System.Nix.Hash (HashAlgo)
|
||||
import System.Nix.OutputName (OutputName, InvalidNameError)
|
||||
import System.Nix.Signature (Signature)
|
||||
import System.Nix.StorePath (StorePath)
|
||||
|
||||
import qualified Data.Bifunctor
|
||||
import qualified Data.Text
|
||||
import qualified Data.Text.Lazy.Builder
|
||||
import qualified System.Nix.Hash
|
||||
|
||||
-- | Output of the derivation
|
||||
data DerivationOutput a = DerivationOutput
|
||||
{ derivationOutputHash :: DSum HashAlgo Digest
|
||||
-- ^ Hash modulo of the derivation
|
||||
, derivationOutputOutput :: a
|
||||
-- ^ Output (either a OutputName or StorePatH)
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
data DerivationOutputError
|
||||
= DerivationOutputError_Digest String
|
||||
| DerivationOutputError_Name InvalidNameError
|
||||
| DerivationOutputError_NoExclamationMark
|
||||
| DerivationOutputError_NoColon
|
||||
| DerivationOutputError_TooManyParts [Text]
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
derivationOutputParser
|
||||
:: (Text -> Either InvalidNameError outputName)
|
||||
-> Text
|
||||
-> Either DerivationOutputError (DerivationOutput outputName)
|
||||
derivationOutputParser outputName dOut =
|
||||
case Data.Text.splitOn (Data.Text.singleton '!') dOut of
|
||||
[] -> Left DerivationOutputError_NoColon
|
||||
[sriHash, oName] -> do
|
||||
hash <-
|
||||
case Data.Text.splitOn (Data.Text.singleton ':') sriHash of
|
||||
[] -> Left DerivationOutputError_NoColon
|
||||
[hashName, digest] ->
|
||||
Data.Bifunctor.first
|
||||
DerivationOutputError_Digest
|
||||
$ System.Nix.Hash.mkNamedDigest hashName digest
|
||||
x -> Left $ DerivationOutputError_TooManyParts x
|
||||
name <-
|
||||
Data.Bifunctor.first
|
||||
DerivationOutputError_Name
|
||||
$ outputName oName
|
||||
|
||||
pure $ DerivationOutput hash name
|
||||
x -> Left $ DerivationOutputError_TooManyParts x
|
||||
|
||||
derivationOutputBuilder
|
||||
:: (outputName -> Text)
|
||||
-> DerivationOutput outputName
|
||||
-> Builder
|
||||
derivationOutputBuilder outputName DerivationOutput{..} =
|
||||
System.Nix.Hash.algoDigestBuilder derivationOutputHash
|
||||
<> Data.Text.Lazy.Builder.singleton '!'
|
||||
<> Data.Text.Lazy.Builder.fromText (outputName derivationOutputOutput)
|
||||
|
||||
-- | Build realisation context
|
||||
--
|
||||
-- realisationId is ommited since it is a key
|
||||
-- of type @DerivationOutput OutputName@ so
|
||||
-- we will use a tuple like @(DerivationOutput OutputName, Realisation)@
|
||||
-- instead.
|
||||
data Realisation = Realisation
|
||||
{ realisationOutPath :: StorePath
|
||||
-- ^ Output path
|
||||
, realisationSignatures :: Set Signature
|
||||
-- ^ Signatures
|
||||
, realisationDependencies :: Map (DerivationOutput OutputName) StorePath
|
||||
-- ^ Dependent realisations required for this one to be valid
|
||||
} deriving (Eq, Generic, Ord, Show)
|
@ -6,13 +6,17 @@ Description : Nix-relevant interfaces to NaCl signatures.
|
||||
|
||||
module System.Nix.Signature
|
||||
( Signature(..)
|
||||
, NarSignature(..)
|
||||
, signatureParser
|
||||
, parseSignature
|
||||
, signatureToText
|
||||
, NarSignature(..)
|
||||
, narSignatureParser
|
||||
, parseNarSignature
|
||||
, narSignatureToText
|
||||
) where
|
||||
|
||||
import Crypto.Error (CryptoFailable(..))
|
||||
import Data.Attoparsec.Text (Parser)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
@ -28,6 +32,26 @@ import qualified Data.Text
|
||||
newtype Signature = Signature Ed25519.Signature
|
||||
deriving (Eq, Generic, Show)
|
||||
|
||||
signatureParser :: Parser Signature
|
||||
signatureParser = do
|
||||
encodedSig <-
|
||||
Data.Attoparsec.Text.takeWhile1
|
||||
(\c -> Data.Char.isAlphaNum c || c == '+' || c == '/' || c == '=')
|
||||
decodedSig <- case decodeWith Base64 encodedSig of
|
||||
Left e -> fail e
|
||||
Right decodedSig -> pure decodedSig
|
||||
sig <- case Ed25519.signature decodedSig of
|
||||
CryptoFailed e -> (fail . show) e
|
||||
CryptoPassed sig -> pure sig
|
||||
pure $ Signature sig
|
||||
|
||||
parseSignature :: Text -> Either String Signature
|
||||
parseSignature = Data.Attoparsec.Text.parseOnly signatureParser
|
||||
|
||||
signatureToText :: Signature -> Text
|
||||
signatureToText (Signature sig) =
|
||||
encodeWith Base64 (Data.ByteArray.convert sig :: ByteString)
|
||||
|
||||
-- | A detached signature attesting to a nix archive's validity.
|
||||
data NarSignature = NarSignature
|
||||
{ -- | The name of the public key used to sign the archive.
|
||||
@ -43,26 +67,19 @@ instance Ord Signature where
|
||||
yBS = Data.ByteArray.convert y :: ByteString
|
||||
in compare xBS yBS
|
||||
|
||||
signatureParser :: Data.Attoparsec.Text.Parser NarSignature
|
||||
signatureParser = do
|
||||
narSignatureParser :: Parser NarSignature
|
||||
narSignatureParser = do
|
||||
publicKey <- Data.Attoparsec.Text.takeWhile1 (/= ':')
|
||||
_ <- Data.Attoparsec.Text.string ":"
|
||||
encodedSig <- Data.Attoparsec.Text.takeWhile1 (\c -> Data.Char.isAlphaNum c || c == '+' || c == '/' || c == '=')
|
||||
decodedSig <- case decodeWith Base64 encodedSig of
|
||||
Left e -> fail e
|
||||
Right decodedSig -> pure decodedSig
|
||||
sig <- case Ed25519.signature decodedSig of
|
||||
CryptoFailed e -> (fail . show) e
|
||||
CryptoPassed sig -> pure sig
|
||||
pure $ NarSignature publicKey (Signature sig)
|
||||
sig <- signatureParser
|
||||
pure $ NarSignature {..}
|
||||
|
||||
parseSignature :: Text -> Either String NarSignature
|
||||
parseSignature = Data.Attoparsec.Text.parseOnly signatureParser
|
||||
parseNarSignature :: Text -> Either String NarSignature
|
||||
parseNarSignature = Data.Attoparsec.Text.parseOnly narSignatureParser
|
||||
|
||||
signatureToText :: NarSignature -> Text
|
||||
signatureToText NarSignature {publicKey, sig=Signature sig'} = let
|
||||
b64Encoded = encodeWith Base64 (Data.ByteArray.convert sig' :: ByteString)
|
||||
in mconcat [ publicKey, ":", b64Encoded ]
|
||||
narSignatureToText :: NarSignature -> Text
|
||||
narSignatureToText NarSignature {..} =
|
||||
mconcat [ publicKey, ":", signatureToText sig ]
|
||||
|
||||
instance Show NarSignature where
|
||||
show narSig = Data.Text.unpack (signatureToText narSig)
|
||||
show narSig = Data.Text.unpack (narSignatureToText narSig)
|
||||
|
@ -17,9 +17,10 @@ module System.Nix.StorePath
|
||||
, StorePathHashPart
|
||||
, mkStorePathHashPart
|
||||
, unStorePathHashPart
|
||||
, -- * Manipulating 'StorePathName'
|
||||
makeStorePathName
|
||||
, validStorePathName
|
||||
-- * Manipulating 'StorePathName'
|
||||
, InvalidNameError(..)
|
||||
, mkStorePathName
|
||||
, parseNameText
|
||||
-- * Reason why a path is not valid
|
||||
, InvalidPathError(..)
|
||||
, -- * Rendering out 'StorePath's
|
||||
@ -115,12 +116,17 @@ mkStorePathHashPart =
|
||||
StorePathHashPart
|
||||
. System.Nix.Hash.mkStorePathHash @hashAlgo
|
||||
|
||||
-- | Reason why a path is not valid
|
||||
data InvalidPathError =
|
||||
EmptyName
|
||||
| PathTooLong
|
||||
-- | Reason why a path name or output name is not valid
|
||||
data InvalidNameError
|
||||
= EmptyName
|
||||
| NameTooLong Int
|
||||
| LeadingDot
|
||||
| InvalidCharacter
|
||||
| InvalidCharacters Text
|
||||
deriving (Eq, Generic, Hashable, Ord, Show)
|
||||
|
||||
-- | Reason why a path is not valid
|
||||
data InvalidPathError
|
||||
= PathNameInvalid InvalidNameError
|
||||
| HashDecodingFailure String
|
||||
| RootDirMismatch
|
||||
{ rdMismatchExpected :: StoreDir
|
||||
@ -129,26 +135,28 @@ data InvalidPathError =
|
||||
deriving (Eq, Generic, Hashable, Ord, Show)
|
||||
|
||||
-- | Make @StorePathName@ from @Text@ (name part of the @StorePath@)
|
||||
-- or fail with @InvalidPathError@ if it isn't valid
|
||||
makeStorePathName :: Text -> Either InvalidPathError StorePathName
|
||||
makeStorePathName n =
|
||||
if validStorePathName n
|
||||
then pure $ StorePathName n
|
||||
else Left $ reasonInvalid n
|
||||
-- or fail with @InvalidNameError@ if it isn't valid
|
||||
mkStorePathName :: Text -> Either InvalidNameError StorePathName
|
||||
mkStorePathName = fmap StorePathName . parseNameText
|
||||
|
||||
reasonInvalid :: Text -> InvalidPathError
|
||||
reasonInvalid n
|
||||
| n == "" = EmptyName
|
||||
| Data.Text.length n > 211 = PathTooLong
|
||||
| Data.Text.head n == '.' = LeadingDot
|
||||
| otherwise = InvalidCharacter
|
||||
|
||||
validStorePathName :: Text -> Bool
|
||||
validStorePathName n =
|
||||
n /= ""
|
||||
&& Data.Text.length n <= 211
|
||||
&& Data.Text.head n /= '.'
|
||||
&& Data.Text.all validStorePathNameChar n
|
||||
-- | Parse name (either @StorePathName@ or @OutputName@)
|
||||
parseNameText :: Text -> Either InvalidNameError Text
|
||||
parseNameText n
|
||||
| n == ""
|
||||
= Left EmptyName
|
||||
| Data.Text.length n > 211
|
||||
= Left $ NameTooLong (Data.Text.length n)
|
||||
| Data.Text.head n == '.'
|
||||
= Left $ LeadingDot
|
||||
| not
|
||||
$ Data.Text.null
|
||||
$ Data.Text.filter
|
||||
(not . validStorePathNameChar)
|
||||
n
|
||||
= Left
|
||||
$ InvalidCharacters
|
||||
$ Data.Text.filter (not . validStorePathNameChar) n
|
||||
| otherwise = pure n
|
||||
|
||||
validStorePathNameChar :: Char -> Bool
|
||||
validStorePathNameChar c =
|
||||
@ -220,11 +228,15 @@ parsePath' expectedRoot stringyPath =
|
||||
let
|
||||
(rootDir, fname) = System.FilePath.splitFileName stringyPath
|
||||
(storeBasedHashPart, namePart) = Data.Text.breakOn "-" $ Data.Text.pack fname
|
||||
hashPart = Data.Bifunctor.bimap
|
||||
HashDecodingFailure
|
||||
StorePathHashPart
|
||||
$ System.Nix.Base.decodeWith NixBase32 storeBasedHashPart
|
||||
name = makeStorePathName . Data.Text.drop 1 $ namePart
|
||||
hashPart =
|
||||
Data.Bifunctor.bimap
|
||||
HashDecodingFailure
|
||||
StorePathHashPart
|
||||
$ System.Nix.Base.decodeWith NixBase32 storeBasedHashPart
|
||||
name =
|
||||
Data.Bifunctor.first
|
||||
PathNameInvalid
|
||||
$ mkStorePathName . Data.Text.drop 1 $ namePart
|
||||
--rootDir' = dropTrailingPathSeparator rootDir
|
||||
-- cannot use ^^ as it drops multiple slashes /a/b/// -> /a/b
|
||||
rootDir' = init rootDir
|
||||
@ -288,11 +300,15 @@ pathParser expectedRoot = do
|
||||
validStorePathNameChar
|
||||
<?> "Path name contains invalid character"
|
||||
|
||||
let name = makeStorePathName $ Data.Text.cons c0 rest
|
||||
hashPart = Data.Bifunctor.bimap
|
||||
HashDecodingFailure
|
||||
StorePathHashPart
|
||||
digest
|
||||
let name =
|
||||
Data.Bifunctor.first
|
||||
PathNameInvalid
|
||||
$ mkStorePathName $ Data.Text.cons c0 rest
|
||||
hashPart =
|
||||
Data.Bifunctor.bimap
|
||||
HashDecodingFailure
|
||||
StorePathHashPart
|
||||
digest
|
||||
|
||||
either
|
||||
(fail . show)
|
||||
|
@ -35,25 +35,25 @@ data StorePathTrust
|
||||
data Metadata a = Metadata
|
||||
{ -- | The path to the derivation file that built this path, if any
|
||||
-- and known.
|
||||
deriverPath :: !(Maybe a)
|
||||
metadataDeriverPath :: !(Maybe a)
|
||||
, -- | The hash of the nar serialization of the path.
|
||||
narHash :: !(DSum HashAlgo Digest)
|
||||
metadataNarHash :: !(DSum HashAlgo Digest)
|
||||
, -- | The paths that this path directly references
|
||||
references :: !(HashSet a)
|
||||
metadataReferences :: !(HashSet a)
|
||||
, -- | When was this path registered valid in the store?
|
||||
registrationTime :: !UTCTime
|
||||
metadataRegistrationTime :: !UTCTime
|
||||
, -- | The size of the nar serialization of the path, in bytes.
|
||||
narBytes :: !(Maybe Word64)
|
||||
metadataNarBytes :: !(Maybe Word64)
|
||||
, -- | How much we trust this path. Nix-es ultimate
|
||||
trust :: !StorePathTrust
|
||||
metadataTrust :: !StorePathTrust
|
||||
, -- | A set of cryptographic attestations of this path's validity.
|
||||
--
|
||||
-- There is no guarantee from this type alone that these
|
||||
-- signatures are valid.
|
||||
sigs :: !(Set NarSignature)
|
||||
metadataSigs :: !(Set NarSignature)
|
||||
, -- | Whether and how this store path is content-addressable.
|
||||
--
|
||||
-- There is no guarantee from this type alone that this address
|
||||
-- is actually correct for this store path.
|
||||
contentAddress :: !(Maybe ContentAddress)
|
||||
metadataContentAddress :: !(Maybe ContentAddress)
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
@ -31,7 +31,11 @@ spec_fingerprint = do
|
||||
|
||||
it "allows a successful signature verification" $ do
|
||||
let msg = Text.encodeUtf8 $ metadataFingerprint def exampleStorePath exampleMetadata
|
||||
Signature sig' = head $ sig <$> filter (\(NarSignature publicKey _) -> publicKey == "cache.nixos.org-1") (Set.toList (sigs exampleMetadata))
|
||||
Signature sig' =
|
||||
head
|
||||
$ sig
|
||||
<$> filter (\(NarSignature publicKey _) -> publicKey == "cache.nixos.org-1")
|
||||
(Set.toList (metadataSigs exampleMetadata))
|
||||
sig' `shouldSatisfy` Ed25519.verify pubkey msg
|
||||
|
||||
exampleFingerprint :: Text
|
||||
@ -42,28 +46,28 @@ exampleStorePath = forceRight $ parsePath def "/nix/store/syd87l2rxw8cbsxmxl853h
|
||||
|
||||
exampleMetadata :: Metadata StorePath
|
||||
exampleMetadata = Metadata
|
||||
{ deriverPath = Just $ forceRight $ parsePath def "/nix/store/5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv"
|
||||
, narHash = forceRight $ mkNamedDigest "sha256" "1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0"
|
||||
, references = HashSet.fromList $ forceRight . parsePath def <$> ["/nix/store/0jqd0rlxzra1rs38rdxl43yh6rxchgc6-curl-7.82.0","/nix/store/6w8g7njm4mck5dmjxws0z1xnrxvl81xa-glibc-2.34-115","/nix/store/j5jxw3iy7bbz4a57fh9g2xm2gxmyal8h-zlib-1.2.12","/nix/store/yxvjs9drzsphm9pcf42a4byzj1kb9m7k-openssl-1.1.1n"]
|
||||
, registrationTime = UTCTime (fromOrdinalDate 0 0) 0
|
||||
, narBytes = Just 196040
|
||||
, trust = BuiltElsewhere
|
||||
, sigs = Set.fromList $ forceRight . parseSignature <$> ["cache.nixos.org-1:TsTTb3WGTZKphvYdBHXwo6weVILmTytUjLB+vcX89fOjjRicCHmKA4RCPMVLkj6TMJ4GMX3HPVWRdD1hkeKZBQ==", "test1:519iiVLx/c4Rdt5DNt6Y2Jm6hcWE9+XY69ygiWSZCNGVcmOcyL64uVAJ3cV8vaTusIZdbTnYo9Y7vDNeTmmMBQ=="]
|
||||
, contentAddress = Nothing
|
||||
{ metadataDeriverPath = Just $ forceRight $ parsePath def "/nix/store/5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv"
|
||||
, metadataNarHash = forceRight $ mkNamedDigest "sha256" "1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0"
|
||||
, metadataReferences = HashSet.fromList $ forceRight . parsePath def <$> ["/nix/store/0jqd0rlxzra1rs38rdxl43yh6rxchgc6-curl-7.82.0","/nix/store/6w8g7njm4mck5dmjxws0z1xnrxvl81xa-glibc-2.34-115","/nix/store/j5jxw3iy7bbz4a57fh9g2xm2gxmyal8h-zlib-1.2.12","/nix/store/yxvjs9drzsphm9pcf42a4byzj1kb9m7k-openssl-1.1.1n"]
|
||||
, metadataRegistrationTime = UTCTime (fromOrdinalDate 0 0) 0
|
||||
, metadataNarBytes = Just 196040
|
||||
, metadataTrust = BuiltElsewhere
|
||||
, metadataSigs = Set.fromList $ forceRight . parseNarSignature <$> ["cache.nixos.org-1:TsTTb3WGTZKphvYdBHXwo6weVILmTytUjLB+vcX89fOjjRicCHmKA4RCPMVLkj6TMJ4GMX3HPVWRdD1hkeKZBQ==", "test1:519iiVLx/c4Rdt5DNt6Y2Jm6hcWE9+XY69ygiWSZCNGVcmOcyL64uVAJ3cV8vaTusIZdbTnYo9Y7vDNeTmmMBQ=="]
|
||||
, metadataContentAddress = Nothing
|
||||
}
|
||||
|
||||
pubkey :: Ed25519.PublicKey
|
||||
pubkey = forceDecodeB64Pubkey "6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY="
|
||||
|
||||
|
||||
forceDecodeB64Pubkey :: Text -> Ed25519.PublicKey
|
||||
forceDecodeB64Pubkey b64EncodedPubkey = let
|
||||
decoded = forceRight $ decodeWith Base64 b64EncodedPubkey
|
||||
in case Ed25519.publicKey decoded of
|
||||
in case Ed25519.publicKey decoded of
|
||||
CryptoFailed err -> (error . show) err
|
||||
CryptoPassed x -> x
|
||||
CryptoPassed x -> x
|
||||
|
||||
forceRight :: Either a b -> b
|
||||
forceRight = \case
|
||||
Right x -> x
|
||||
_ -> error "fromRight failed"
|
||||
_ -> error "forceRight failed"
|
||||
|
||||
|
@ -54,24 +54,24 @@ pubkeyNixosOrg :: Crypto.PubKey.Ed25519.PublicKey
|
||||
pubkeyNixosOrg = forceDecodeB64Pubkey "6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY="
|
||||
|
||||
shouldNotParse :: Text -> Expectation
|
||||
shouldNotParse encoded = case parseSignature encoded of
|
||||
shouldNotParse encoded = case parseNarSignature encoded of
|
||||
Left _ -> pure ()
|
||||
Right _ -> expectationFailure "should not have parsed"
|
||||
|
||||
shouldParseName :: Text -> Text -> Expectation
|
||||
shouldParseName encoded name = case parseSignature encoded of
|
||||
shouldParseName encoded name = case parseNarSignature encoded of
|
||||
Left err -> expectationFailure err
|
||||
Right narSig -> shouldBe name (publicKey narSig)
|
||||
|
||||
shouldVerify :: Text -> Crypto.PubKey.Ed25519.PublicKey -> BS.ByteString -> Expectation
|
||||
shouldVerify encoded pubkey msg = case parseSignature encoded of
|
||||
shouldVerify encoded pubkey msg = case parseNarSignature encoded of
|
||||
Left err -> expectationFailure err
|
||||
Right narSig -> let
|
||||
(Signature sig') = sig narSig
|
||||
in sig' `shouldSatisfy` Crypto.PubKey.Ed25519.verify pubkey msg
|
||||
|
||||
shouldNotVerify :: Text -> Crypto.PubKey.Ed25519.PublicKey -> BS.ByteString -> Expectation
|
||||
shouldNotVerify encoded pubkey msg = case parseSignature encoded of
|
||||
shouldNotVerify encoded pubkey msg = case parseNarSignature encoded of
|
||||
Left err -> expectationFailure err
|
||||
Right narSig -> let
|
||||
(Signature sig') = sig narSig
|
||||
|
37
hnix-store-core/tests/StorePath.hs
Normal file
37
hnix-store-core/tests/StorePath.hs
Normal file
@ -0,0 +1,37 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module StorePath where
|
||||
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
import qualified Data.Text
|
||||
|
||||
import System.Nix.StorePath (parseNameText, InvalidNameError(..))
|
||||
|
||||
spec_storePath :: Spec
|
||||
spec_storePath = do
|
||||
describe "parseNameText" $ do
|
||||
it "parses valid name" $
|
||||
parseNameText "name-dev.dotok"
|
||||
`shouldBe`
|
||||
pure "name-dev.dotok"
|
||||
|
||||
it "fails on empty" $
|
||||
parseNameText mempty
|
||||
`shouldBe`
|
||||
Left EmptyName
|
||||
|
||||
it "fails on too long" $
|
||||
parseNameText (Data.Text.replicate 256 "n")
|
||||
`shouldBe`
|
||||
Left (NameTooLong 256)
|
||||
|
||||
it "fails on leading dot" $
|
||||
parseNameText ".ab"
|
||||
`shouldBe`
|
||||
Left LeadingDot
|
||||
|
||||
it "fails on invalid characters" $
|
||||
parseNameText "ab!cd#@"
|
||||
`shouldBe`
|
||||
Left (InvalidCharacters "!#@")
|
10
hnix-store-json/CHANGELOG.md
Normal file
10
hnix-store-json/CHANGELOG.md
Normal file
@ -0,0 +1,10 @@
|
||||
# Version [0.1.0.0](https://github.com/haskell-nix/hnix-store/compare/json-0.1.0.0...json-0.1.1.0) (2023-11-27)
|
||||
|
||||
* Initial release
|
||||
|
||||
---
|
||||
|
||||
`hnix-store-json` uses [PVP Versioning][1].
|
||||
|
||||
[1]: https://pvp.haskell.org
|
||||
|
201
hnix-store-json/LICENSE
Normal file
201
hnix-store-json/LICENSE
Normal file
@ -0,0 +1,201 @@
|
||||
Apache License
|
||||
Version 2.0, January 2004
|
||||
http://www.apache.org/licenses/
|
||||
|
||||
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
|
||||
|
||||
1. Definitions.
|
||||
|
||||
"License" shall mean the terms and conditions for use, reproduction,
|
||||
and distribution as defined by Sections 1 through 9 of this document.
|
||||
|
||||
"Licensor" shall mean the copyright owner or entity authorized by
|
||||
the copyright owner that is granting the License.
|
||||
|
||||
"Legal Entity" shall mean the union of the acting entity and all
|
||||
other entities that control, are controlled by, or are under common
|
||||
control with that entity. For the purposes of this definition,
|
||||
"control" means (i) the power, direct or indirect, to cause the
|
||||
direction or management of such entity, whether by contract or
|
||||
otherwise, or (ii) ownership of fifty percent (50%) or more of the
|
||||
outstanding shares, or (iii) beneficial ownership of such entity.
|
||||
|
||||
"You" (or "Your") shall mean an individual or Legal Entity
|
||||
exercising permissions granted by this License.
|
||||
|
||||
"Source" form shall mean the preferred form for making modifications,
|
||||
including but not limited to software source code, documentation
|
||||
source, and configuration files.
|
||||
|
||||
"Object" form shall mean any form resulting from mechanical
|
||||
transformation or translation of a Source form, including but
|
||||
not limited to compiled object code, generated documentation,
|
||||
and conversions to other media types.
|
||||
|
||||
"Work" shall mean the work of authorship, whether in Source or
|
||||
Object form, made available under the License, as indicated by a
|
||||
copyright notice that is included in or attached to the work
|
||||
(an example is provided in the Appendix below).
|
||||
|
||||
"Derivative Works" shall mean any work, whether in Source or Object
|
||||
form, that is based on (or derived from) the Work and for which the
|
||||
editorial revisions, annotations, elaborations, or other modifications
|
||||
represent, as a whole, an original work of authorship. For the purposes
|
||||
of this License, Derivative Works shall not include works that remain
|
||||
separable from, or merely link (or bind by name) to the interfaces of,
|
||||
the Work and Derivative Works thereof.
|
||||
|
||||
"Contribution" shall mean any work of authorship, including
|
||||
the original version of the Work and any modifications or additions
|
||||
to that Work or Derivative Works thereof, that is intentionally
|
||||
submitted to Licensor for inclusion in the Work by the copyright owner
|
||||
or by an individual or Legal Entity authorized to submit on behalf of
|
||||
the copyright owner. For the purposes of this definition, "submitted"
|
||||
means any form of electronic, verbal, or written communication sent
|
||||
to the Licensor or its representatives, including but not limited to
|
||||
communication on electronic mailing lists, source code control systems,
|
||||
and issue tracking systems that are managed by, or on behalf of, the
|
||||
Licensor for the purpose of discussing and improving the Work, but
|
||||
excluding communication that is conspicuously marked or otherwise
|
||||
designated in writing by the copyright owner as "Not a Contribution."
|
||||
|
||||
"Contributor" shall mean Licensor and any individual or Legal Entity
|
||||
on behalf of whom a Contribution has been received by Licensor and
|
||||
subsequently incorporated within the Work.
|
||||
|
||||
2. Grant of Copyright License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
copyright license to reproduce, prepare Derivative Works of,
|
||||
publicly display, publicly perform, sublicense, and distribute the
|
||||
Work and such Derivative Works in Source or Object form.
|
||||
|
||||
3. Grant of Patent License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
(except as stated in this section) patent license to make, have made,
|
||||
use, offer to sell, sell, import, and otherwise transfer the Work,
|
||||
where such license applies only to those patent claims licensable
|
||||
by such Contributor that are necessarily infringed by their
|
||||
Contribution(s) alone or by combination of their Contribution(s)
|
||||
with the Work to which such Contribution(s) was submitted. If You
|
||||
institute patent litigation against any entity (including a
|
||||
cross-claim or counterclaim in a lawsuit) alleging that the Work
|
||||
or a Contribution incorporated within the Work constitutes direct
|
||||
or contributory patent infringement, then any patent licenses
|
||||
granted to You under this License for that Work shall terminate
|
||||
as of the date such litigation is filed.
|
||||
|
||||
4. Redistribution. You may reproduce and distribute copies of the
|
||||
Work or Derivative Works thereof in any medium, with or without
|
||||
modifications, and in Source or Object form, provided that You
|
||||
meet the following conditions:
|
||||
|
||||
(a) You must give any other recipients of the Work or
|
||||
Derivative Works a copy of this License; and
|
||||
|
||||
(b) You must cause any modified files to carry prominent notices
|
||||
stating that You changed the files; and
|
||||
|
||||
(c) You must retain, in the Source form of any Derivative Works
|
||||
that You distribute, all copyright, patent, trademark, and
|
||||
attribution notices from the Source form of the Work,
|
||||
excluding those notices that do not pertain to any part of
|
||||
the Derivative Works; and
|
||||
|
||||
(d) If the Work includes a "NOTICE" text file as part of its
|
||||
distribution, then any Derivative Works that You distribute must
|
||||
include a readable copy of the attribution notices contained
|
||||
within such NOTICE file, excluding those notices that do not
|
||||
pertain to any part of the Derivative Works, in at least one
|
||||
of the following places: within a NOTICE text file distributed
|
||||
as part of the Derivative Works; within the Source form or
|
||||
documentation, if provided along with the Derivative Works; or,
|
||||
within a display generated by the Derivative Works, if and
|
||||
wherever such third-party notices normally appear. The contents
|
||||
of the NOTICE file are for informational purposes only and
|
||||
do not modify the License. You may add Your own attribution
|
||||
notices within Derivative Works that You distribute, alongside
|
||||
or as an addendum to the NOTICE text from the Work, provided
|
||||
that such additional attribution notices cannot be construed
|
||||
as modifying the License.
|
||||
|
||||
You may add Your own copyright statement to Your modifications and
|
||||
may provide additional or different license terms and conditions
|
||||
for use, reproduction, or distribution of Your modifications, or
|
||||
for any such Derivative Works as a whole, provided Your use,
|
||||
reproduction, and distribution of the Work otherwise complies with
|
||||
the conditions stated in this License.
|
||||
|
||||
5. Submission of Contributions. Unless You explicitly state otherwise,
|
||||
any Contribution intentionally submitted for inclusion in the Work
|
||||
by You to the Licensor shall be under the terms and conditions of
|
||||
this License, without any additional terms or conditions.
|
||||
Notwithstanding the above, nothing herein shall supersede or modify
|
||||
the terms of any separate license agreement you may have executed
|
||||
with Licensor regarding such Contributions.
|
||||
|
||||
6. Trademarks. This License does not grant permission to use the trade
|
||||
names, trademarks, service marks, or product names of the Licensor,
|
||||
except as required for reasonable and customary use in describing the
|
||||
origin of the Work and reproducing the content of the NOTICE file.
|
||||
|
||||
7. Disclaimer of Warranty. Unless required by applicable law or
|
||||
agreed to in writing, Licensor provides the Work (and each
|
||||
Contributor provides its Contributions) on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
|
||||
implied, including, without limitation, any warranties or conditions
|
||||
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. You are solely responsible for determining the
|
||||
appropriateness of using or redistributing the Work and assume any
|
||||
risks associated with Your exercise of permissions under this License.
|
||||
|
||||
8. Limitation of Liability. In no event and under no legal theory,
|
||||
whether in tort (including negligence), contract, or otherwise,
|
||||
unless required by applicable law (such as deliberate and grossly
|
||||
negligent acts) or agreed to in writing, shall any Contributor be
|
||||
liable to You for damages, including any direct, indirect, special,
|
||||
incidental, or consequential damages of any character arising as a
|
||||
result of this License or out of the use or inability to use the
|
||||
Work (including but not limited to damages for loss of goodwill,
|
||||
work stoppage, computer failure or malfunction, or any and all
|
||||
other commercial damages or losses), even if such Contributor
|
||||
has been advised of the possibility of such damages.
|
||||
|
||||
9. Accepting Warranty or Additional Liability. While redistributing
|
||||
the Work or Derivative Works thereof, You may choose to offer,
|
||||
and charge a fee for, acceptance of support, warranty, indemnity,
|
||||
or other liability obligations and/or rights consistent with this
|
||||
License. However, in accepting such obligations, You may act only
|
||||
on Your own behalf and on Your sole responsibility, not on behalf
|
||||
of any other Contributor, and only if You agree to indemnify,
|
||||
defend, and hold each Contributor harmless for any liability
|
||||
incurred by, or claims asserted against, such Contributor by reason
|
||||
of your accepting any such warranty or additional liability.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
APPENDIX: How to apply the Apache License to your work.
|
||||
|
||||
To apply the Apache License to your work, attach the following
|
||||
boilerplate notice, with the fields enclosed by brackets "[]"
|
||||
replaced with your own identifying information. (Don't include
|
||||
the brackets!) The text should be enclosed in the appropriate
|
||||
comment syntax for the file format. We also recommend that a
|
||||
file or class name and description of purpose be included on the
|
||||
same "printed page" as the copyright notice for easier
|
||||
identification within third-party archives.
|
||||
|
||||
Copyright 2018 Shea Levy.
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License");
|
||||
you may not use this file except in compliance with the License.
|
||||
You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
See the License for the specific language governing permissions and
|
||||
limitations under the License.
|
3
hnix-store-json/README.md
Normal file
3
hnix-store-json/README.md
Normal file
@ -0,0 +1,3 @@
|
||||
# hnix-store-json
|
||||
|
||||
Aeson instances for core types.
|
64
hnix-store-json/hnix-store-json.cabal
Normal file
64
hnix-store-json/hnix-store-json.cabal
Normal file
@ -0,0 +1,64 @@
|
||||
cabal-version: 2.2
|
||||
name: hnix-store-json
|
||||
version: 0.1.0.0
|
||||
synopsis: JSON serialization for core types
|
||||
description:
|
||||
Aeson instances for core types
|
||||
homepage: https://github.com/haskell-nix/hnix-store
|
||||
license: Apache-2.0
|
||||
license-file: LICENSE
|
||||
author: Richard Marko
|
||||
maintainer: srk@48.io
|
||||
copyright: 2023 Richard Marko
|
||||
category: Nix
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
, README.md
|
||||
|
||||
common commons
|
||||
ghc-options: -Wall
|
||||
default-extensions:
|
||||
DataKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingVia
|
||||
, FlexibleInstances
|
||||
, LambdaCase
|
||||
, RecordWildCards
|
||||
, StandaloneDeriving
|
||||
, TypeApplications
|
||||
default-language: Haskell2010
|
||||
|
||||
library
|
||||
import: commons
|
||||
exposed-modules:
|
||||
System.Nix.JSON
|
||||
build-depends:
|
||||
base >=4.12 && <5
|
||||
, hnix-store-core >= 0.8
|
||||
, aeson >= 2.0 && < 3.0
|
||||
, attoparsec
|
||||
, deriving-aeson >= 0.2
|
||||
, text
|
||||
hs-source-dirs: src
|
||||
|
||||
test-suite json
|
||||
import: commons
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
JSONSpec
|
||||
hs-source-dirs:
|
||||
tests
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover
|
||||
build-depends:
|
||||
base
|
||||
, hnix-store-core
|
||||
, hnix-store-json
|
||||
, hnix-store-tests
|
||||
, aeson
|
||||
, containers
|
||||
, data-default-class
|
||||
, hspec
|
176
hnix-store-json/src/System/Nix/JSON.hs
Normal file
176
hnix-store-json/src/System/Nix/JSON.hs
Normal file
@ -0,0 +1,176 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-|
|
||||
Description : JSON serialization
|
||||
|
||||
This module is mostly a stub for now
|
||||
providing (From|To)JSON for Realisation type
|
||||
which is required for `-remote`.
|
||||
-}
|
||||
module System.Nix.JSON where
|
||||
|
||||
import Data.Aeson
|
||||
import Deriving.Aeson
|
||||
import System.Nix.Base (BaseEncoding(NixBase32))
|
||||
import System.Nix.OutputName (OutputName)
|
||||
import System.Nix.Realisation (DerivationOutput, Realisation)
|
||||
import System.Nix.Signature (Signature)
|
||||
import System.Nix.StorePath (StoreDir(..), StorePath, StorePathName, StorePathHashPart)
|
||||
|
||||
import qualified Data.Aeson.KeyMap
|
||||
import qualified Data.Aeson.Types
|
||||
import qualified Data.Attoparsec.Text
|
||||
import qualified Data.Char
|
||||
import qualified Data.Text
|
||||
import qualified Data.Text.Lazy
|
||||
import qualified Data.Text.Lazy.Builder
|
||||
import qualified System.Nix.Base
|
||||
import qualified System.Nix.OutputName
|
||||
import qualified System.Nix.Realisation
|
||||
import qualified System.Nix.Signature
|
||||
import qualified System.Nix.StorePath
|
||||
|
||||
instance ToJSON StorePathName where
|
||||
toJSON = toJSON . System.Nix.StorePath.unStorePathName
|
||||
toEncoding = toEncoding . System.Nix.StorePath.unStorePathName
|
||||
|
||||
instance FromJSON StorePathName where
|
||||
parseJSON =
|
||||
withText "StorePathName"
|
||||
( either (fail . show) pure
|
||||
. System.Nix.StorePath.mkStorePathName)
|
||||
|
||||
instance ToJSON StorePathHashPart where
|
||||
toJSON = toJSON . System.Nix.StorePath.storePathHashPartToText
|
||||
toEncoding = toEncoding . System.Nix.StorePath.storePathHashPartToText
|
||||
|
||||
instance FromJSON StorePathHashPart where
|
||||
parseJSON =
|
||||
withText "StorePathHashPart"
|
||||
( either
|
||||
(fail . show)
|
||||
(pure . System.Nix.StorePath.unsafeMakeStorePathHashPart)
|
||||
. System.Nix.Base.decodeWith NixBase32
|
||||
)
|
||||
|
||||
instance ToJSON StorePath where
|
||||
toJSON =
|
||||
toJSON
|
||||
-- TODO: hacky, we need to stop requiring StoreDir for
|
||||
-- StorePath rendering and have a distinct
|
||||
-- types for rooted|unrooted paths
|
||||
. Data.Text.drop 1
|
||||
. System.Nix.StorePath.storePathToText (StoreDir mempty)
|
||||
|
||||
toEncoding =
|
||||
toEncoding
|
||||
. Data.Text.drop 1
|
||||
. System.Nix.StorePath.storePathToText (StoreDir mempty)
|
||||
|
||||
instance FromJSON StorePath where
|
||||
parseJSON =
|
||||
withText "StorePath"
|
||||
( either
|
||||
(fail . show)
|
||||
pure
|
||||
. System.Nix.StorePath.parsePathFromText (StoreDir mempty)
|
||||
. Data.Text.cons '/'
|
||||
)
|
||||
|
||||
instance ToJSON (DerivationOutput OutputName) where
|
||||
toJSON =
|
||||
toJSON
|
||||
. Data.Text.Lazy.toStrict
|
||||
. Data.Text.Lazy.Builder.toLazyText
|
||||
. System.Nix.Realisation.derivationOutputBuilder
|
||||
System.Nix.OutputName.unOutputName
|
||||
|
||||
toEncoding =
|
||||
toEncoding
|
||||
. Data.Text.Lazy.toStrict
|
||||
. Data.Text.Lazy.Builder.toLazyText
|
||||
. System.Nix.Realisation.derivationOutputBuilder
|
||||
System.Nix.OutputName.unOutputName
|
||||
|
||||
instance ToJSONKey (DerivationOutput OutputName) where
|
||||
toJSONKey =
|
||||
Data.Aeson.Types.toJSONKeyText
|
||||
$ Data.Text.Lazy.toStrict
|
||||
. Data.Text.Lazy.Builder.toLazyText
|
||||
. System.Nix.Realisation.derivationOutputBuilder
|
||||
System.Nix.OutputName.unOutputName
|
||||
|
||||
instance FromJSON (DerivationOutput OutputName) where
|
||||
parseJSON =
|
||||
withText "DerivationOutput OutputName"
|
||||
( either
|
||||
(fail . show)
|
||||
pure
|
||||
. System.Nix.Realisation.derivationOutputParser
|
||||
System.Nix.OutputName.mkOutputName
|
||||
)
|
||||
|
||||
instance FromJSONKey (DerivationOutput OutputName) where
|
||||
fromJSONKey =
|
||||
FromJSONKeyTextParser
|
||||
( either
|
||||
(fail . show)
|
||||
pure
|
||||
. System.Nix.Realisation.derivationOutputParser
|
||||
System.Nix.OutputName.mkOutputName
|
||||
)
|
||||
|
||||
instance ToJSON Signature where
|
||||
toJSON = toJSON . System.Nix.Signature.signatureToText
|
||||
toEncoding = toEncoding . System.Nix.Signature.signatureToText
|
||||
|
||||
instance FromJSON Signature where
|
||||
parseJSON =
|
||||
withText "Signature"
|
||||
( either
|
||||
(fail . show)
|
||||
pure
|
||||
. Data.Attoparsec.Text.parseOnly
|
||||
System.Nix.Signature.signatureParser
|
||||
)
|
||||
|
||||
data LowerLeading
|
||||
instance StringModifier LowerLeading where
|
||||
getStringModifier "" = ""
|
||||
getStringModifier (c:xs) = Data.Char.toLower c : xs
|
||||
|
||||
deriving
|
||||
via CustomJSON
|
||||
'[FieldLabelModifier
|
||||
'[ StripPrefix "realisation"
|
||||
, LowerLeading
|
||||
, Rename "dependencies" "dependentRealisations"
|
||||
]
|
||||
] Realisation
|
||||
instance ToJSON Realisation
|
||||
deriving
|
||||
via CustomJSON
|
||||
'[FieldLabelModifier
|
||||
'[ StripPrefix "realisation"
|
||||
, LowerLeading
|
||||
, Rename "dependencies" "dependentRealisations"
|
||||
]
|
||||
] Realisation
|
||||
instance FromJSON Realisation
|
||||
|
||||
-- For a keyed version of Realisation
|
||||
-- we use (DerivationOutput OutputName, Realisation)
|
||||
-- instead of Realisation.id :: (DerivationOutput OutputName)
|
||||
-- field.
|
||||
instance {-# OVERLAPPING #-} ToJSON (DerivationOutput OutputName, Realisation) where
|
||||
toJSON (drvOut, r) =
|
||||
case toJSON r of
|
||||
Object o -> Object $ Data.Aeson.KeyMap.insert "id" (toJSON drvOut) o
|
||||
_ -> error "absurd"
|
||||
|
||||
instance {-# OVERLAPPING #-} FromJSON (DerivationOutput OutputName, Realisation) where
|
||||
parseJSON v@(Object o) = do
|
||||
r <- parseJSON @Realisation v
|
||||
drvOut <- o .: "id"
|
||||
pure (drvOut, r)
|
||||
parseJSON x = fail $ "Expected Object but got " ++ show x
|
101
hnix-store-json/tests/JSONSpec.hs
Normal file
101
hnix-store-json/tests/JSONSpec.hs
Normal file
@ -0,0 +1,101 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module JSONSpec where
|
||||
|
||||
import Data.Aeson (ToJSON, FromJSON, decode, encode)
|
||||
import Data.Default.Class (Default(def))
|
||||
import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
|
||||
import Test.Hspec.QuickCheck (prop)
|
||||
import Test.Hspec.Nix (forceRight, roundtrips)
|
||||
|
||||
import System.Nix.Arbitrary ()
|
||||
import System.Nix.JSON ()
|
||||
import System.Nix.OutputName (OutputName)
|
||||
import System.Nix.Realisation (DerivationOutput(..), Realisation(..))
|
||||
import System.Nix.Signature (Signature)
|
||||
import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart)
|
||||
|
||||
import qualified Data.Map
|
||||
import qualified Data.Set
|
||||
import qualified System.Nix.Hash
|
||||
import qualified System.Nix.OutputName
|
||||
import qualified System.Nix.Signature
|
||||
import qualified System.Nix.StorePath
|
||||
|
||||
roundtripsJSON
|
||||
:: ( Eq a
|
||||
, Show a
|
||||
, ToJSON a
|
||||
, FromJSON a
|
||||
)
|
||||
=> a
|
||||
-> Expectation
|
||||
roundtripsJSON = roundtrips encode decode
|
||||
|
||||
sampleDerivationOutput :: DerivationOutput OutputName
|
||||
sampleDerivationOutput = DerivationOutput
|
||||
{ derivationOutputHash =
|
||||
forceRight
|
||||
$ System.Nix.Hash.mkNamedDigest
|
||||
"sha256"
|
||||
"1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0"
|
||||
, derivationOutputOutput =
|
||||
forceRight
|
||||
$ System.Nix.OutputName.mkOutputName "foo"
|
||||
}
|
||||
|
||||
sampleRealisation0 :: Realisation
|
||||
sampleRealisation0 = Realisation
|
||||
{ realisationOutPath =
|
||||
forceRight
|
||||
$ System.Nix.StorePath.parsePath
|
||||
def
|
||||
"/nix/store/cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.sh"
|
||||
, realisationSignatures = mempty
|
||||
, realisationDependencies = mempty
|
||||
}
|
||||
|
||||
sampleRealisation1 :: Realisation
|
||||
sampleRealisation1 = Realisation
|
||||
{ realisationOutPath =
|
||||
forceRight
|
||||
$ System.Nix.StorePath.parsePath
|
||||
def
|
||||
"/nix/store/5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv"
|
||||
, realisationSignatures =
|
||||
Data.Set.fromList
|
||||
$ forceRight
|
||||
. System.Nix.Signature.parseSignature
|
||||
<$> [ "fW3iEMfyx6IZzGNswD54BjclfkXiYzh0xRXddrXfJ1rp1l8p1xTi9/0g2EibbwLFb6p83cwIJv5KtTGksC54CQ=="
|
||||
, "SMjnB3mPgXYjXacU+xN24BdzXlAgGAuFnYwPddU3bhjfHBeQus/OimdIPMgR/JMKFPHXORrk7pbjv68vecTEBA=="
|
||||
]
|
||||
, realisationDependencies =
|
||||
Data.Map.fromList
|
||||
[ ( sampleDerivationOutput
|
||||
, forceRight
|
||||
$ System.Nix.StorePath.parsePathFromText
|
||||
def
|
||||
"/nix/store/9472ijanf79nlkb5n1yh57s7867p1930-testFixed"
|
||||
)
|
||||
]
|
||||
}
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "JSON" $ do
|
||||
describe "roundtrips" $ do
|
||||
prop "StorePathName" $ roundtripsJSON @StorePathName
|
||||
prop "StorePathHashPart" $ roundtripsJSON @StorePathHashPart
|
||||
prop "StorePath" $ roundtripsJSON @StorePath
|
||||
prop "DerivationOutput OutputName" $ roundtripsJSON @(DerivationOutput OutputName)
|
||||
prop "Signature" $ roundtripsJSON @Signature
|
||||
prop "Realisation" $ roundtripsJSON @Realisation
|
||||
|
||||
describe "ground truth" $ do
|
||||
it "sampleDerivationOutput matches preimage" $
|
||||
encode sampleDerivationOutput `shouldBe` "\"sha256:1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0!foo\""
|
||||
|
||||
it "sampleRealisation0 matches preimage" $
|
||||
encode sampleRealisation0 `shouldBe` "{\"outPath\":\"cdips4lakfk1qbf1x68fq18wnn3r5r14-builder.sh\",\"signatures\":[],\"dependentRealisations\":{}}"
|
||||
|
||||
it "sampleRealisation1 matches preimage" $
|
||||
encode sampleRealisation1 `shouldBe` "{\"outPath\":\"5rwxzi7pal3qhpsyfc16gzkh939q1np6-curl-7.82.0.drv\",\"signatures\":[\"SMjnB3mPgXYjXacU+xN24BdzXlAgGAuFnYwPddU3bhjfHBeQus/OimdIPMgR/JMKFPHXORrk7pbjv68vecTEBA==\",\"fW3iEMfyx6IZzGNswD54BjclfkXiYzh0xRXddrXfJ1rp1l8p1xTi9/0g2EibbwLFb6p83cwIJv5KtTGksC54CQ==\"],\"dependentRealisations\":{\"sha256:1b4sb93wp679q4zx9k1ignby1yna3z7c4c2ri3wphylbc2dwsys0!foo\":\"9472ijanf79nlkb5n1yh57s7867p1930-testFixed\"}}"
|
1
hnix-store-json/tests/Spec.hs
Normal file
1
hnix-store-json/tests/Spec.hs
Normal file
@ -0,0 +1 @@
|
||||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
@ -21,7 +21,7 @@ testDigest = Crypto.Hash.hash @ByteString "testDigest"
|
||||
testName :: StorePathName
|
||||
testName =
|
||||
either undefined id
|
||||
$ System.Nix.StorePath.makeStorePathName "testFixed"
|
||||
$ System.Nix.StorePath.mkStorePathName "testFixed"
|
||||
|
||||
testPath :: StorePath
|
||||
testPath =
|
||||
|
@ -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
|
||||
```
|
||||
|
@ -20,6 +20,7 @@ common commons
|
||||
ghc-options: -Wall
|
||||
default-extensions:
|
||||
DataKinds
|
||||
, DefaultSignatures
|
||||
, DeriveGeneric
|
||||
, DeriveDataTypeable
|
||||
, DeriveFunctor
|
||||
@ -34,6 +35,7 @@ common commons
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
, TypeApplications
|
||||
, TypeOperators
|
||||
, TypeSynonymInstances
|
||||
, InstanceSigs
|
||||
, KindSignatures
|
||||
@ -75,35 +77,49 @@ library
|
||||
, Data.Serializer.Example
|
||||
, System.Nix.Store.Remote
|
||||
, System.Nix.Store.Remote.Arbitrary
|
||||
, System.Nix.Store.Remote.Client
|
||||
, System.Nix.Store.Remote.Client.Core
|
||||
, System.Nix.Store.Remote.Logger
|
||||
, System.Nix.Store.Remote.MonadStore
|
||||
, System.Nix.Store.Remote.Protocol
|
||||
, System.Nix.Store.Remote.Serialize
|
||||
, System.Nix.Store.Remote.Serialize.Prim
|
||||
, System.Nix.Store.Remote.Serializer
|
||||
, System.Nix.Store.Remote.Server
|
||||
, System.Nix.Store.Remote.Socket
|
||||
, System.Nix.Store.Remote.Types
|
||||
, System.Nix.Store.Remote.Types.Activity
|
||||
, System.Nix.Store.Remote.Types.CheckMode
|
||||
, System.Nix.Store.Remote.Types.GC
|
||||
, System.Nix.Store.Remote.Types.Handshake
|
||||
, System.Nix.Store.Remote.Types.Logger
|
||||
, System.Nix.Store.Remote.Types.ProtoVersion
|
||||
, System.Nix.Store.Remote.Types.Query
|
||||
, System.Nix.Store.Remote.Types.Query.Missing
|
||||
, System.Nix.Store.Remote.Types.StoreConfig
|
||||
, System.Nix.Store.Remote.Types.StoreRequest
|
||||
, System.Nix.Store.Remote.Types.StoreReply
|
||||
, System.Nix.Store.Remote.Types.StoreText
|
||||
, System.Nix.Store.Remote.Types.SubstituteMode
|
||||
, System.Nix.Store.Remote.Types.TrustedFlag
|
||||
, System.Nix.Store.Remote.Types.Verbosity
|
||||
, System.Nix.Store.Remote.Types.WorkerMagic
|
||||
, System.Nix.Store.Remote.Types.WorkerOp
|
||||
|
||||
build-depends:
|
||||
base >=4.12 && <5
|
||||
, hnix-store-core >= 0.8 && <0.9
|
||||
, hnix-store-json >= 0.1
|
||||
, hnix-store-nar >= 0.1
|
||||
, hnix-store-tests >= 0.1
|
||||
, aeson
|
||||
, attoparsec
|
||||
, bytestring
|
||||
, cereal
|
||||
, containers
|
||||
, concurrency
|
||||
, crypton
|
||||
, data-default-class
|
||||
, dependent-sum > 0.7 && < 1
|
||||
, dependent-sum > 0.7
|
||||
, dependent-sum-template >= 0.2.0.1 && < 0.3
|
||||
, dlist >= 1.0
|
||||
, generic-arbitrary < 1.1
|
||||
, hashable
|
||||
, text
|
||||
@ -112,8 +128,8 @@ library
|
||||
, network
|
||||
, mtl
|
||||
, QuickCheck
|
||||
, quickcheck-instances
|
||||
, unordered-containers
|
||||
, unix >= 2.7
|
||||
, vector
|
||||
hs-source-dirs: src
|
||||
ghc-options: -Wall
|
||||
@ -138,6 +154,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
|
||||
@ -153,8 +170,8 @@ test-suite remote
|
||||
ghc-options: -Wall -threaded -rtsopts "-with-rtsopts -N"
|
||||
other-modules:
|
||||
Data.SerializerSpec
|
||||
EnumSpec
|
||||
NixSerializerSpec
|
||||
SerializeSpec
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover
|
||||
build-depends:
|
||||
@ -162,16 +179,12 @@ test-suite remote
|
||||
, hnix-store-core
|
||||
, hnix-store-remote
|
||||
, hnix-store-tests
|
||||
, cereal
|
||||
, bytestring
|
||||
, crypton
|
||||
, dependent-sum > 0.7 && < 1
|
||||
, some > 1.0.5 && < 2
|
||||
, text
|
||||
, time
|
||||
, hspec
|
||||
, QuickCheck
|
||||
, quickcheck-instances
|
||||
, unordered-containers
|
||||
|
||||
test-suite remote-io
|
||||
import: tests
|
||||
@ -180,20 +193,18 @@ test-suite remote-io
|
||||
buildable: False
|
||||
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Driver.hs
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: tests-io
|
||||
-- See https://github.com/redneb/hs-linux-namespaces/issues/3
|
||||
ghc-options: -rtsopts -fprof-auto "-with-rtsopts -V0"
|
||||
other-modules:
|
||||
NixDaemon
|
||||
, Spec
|
||||
build-tool-depends:
|
||||
tasty-discover:tasty-discover
|
||||
NixDaemonSpec
|
||||
build-depends:
|
||||
base >=4.12 && <5
|
||||
, hnix-store-core
|
||||
, hnix-store-nar
|
||||
, hnix-store-remote
|
||||
, hnix-store-tests
|
||||
, bytestring
|
||||
, containers
|
||||
, crypton
|
||||
@ -203,8 +214,7 @@ test-suite remote-io
|
||||
, hspec-expectations-lifted
|
||||
, linux-namespaces
|
||||
, process
|
||||
, tasty
|
||||
, tasty-hspec
|
||||
, some
|
||||
, temporary
|
||||
, text
|
||||
, unix
|
||||
|
@ -151,7 +151,8 @@ mapIsoSerializer
|
||||
:: Functor (t Get)
|
||||
=> (a -> b) -- ^ Map over @getS@
|
||||
-> (b -> a) -- ^ Map over @putS@
|
||||
-> (Serializer t a -> Serializer t b)
|
||||
-> Serializer t a
|
||||
-> Serializer t b
|
||||
mapIsoSerializer f g s = Serializer
|
||||
{ getS = f <$> getS s
|
||||
, putS = putS s . g
|
||||
@ -163,7 +164,8 @@ mapPrismSerializer
|
||||
:: MonadError eGet (t Get)
|
||||
=> (a -> Either eGet b) -- ^ Map over @getS@
|
||||
-> (b -> a) -- ^ Map over @putS@
|
||||
-> (Serializer t a -> Serializer t b)
|
||||
-> Serializer t a
|
||||
-> Serializer t b
|
||||
mapPrismSerializer f g s = Serializer
|
||||
{ getS = either throwError pure . f =<< getS s
|
||||
, putS = putS s . g
|
||||
@ -193,7 +195,7 @@ tup a b = Serializer
|
||||
data GetSerializerError customGetError
|
||||
= SerializerError_GetFail String
|
||||
| SerializerError_Get customGetError
|
||||
deriving (Eq, Show)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Helper for transforming nested Eithers
|
||||
-- into @GetSerializerError@ wrapper
|
||||
|
@ -39,13 +39,19 @@ import Data.ByteString (ByteString)
|
||||
import Data.Int (Int8)
|
||||
import Data.GADT.Show (GShow(..), defaultGshowsPrec)
|
||||
import Data.Kind (Type)
|
||||
import Data.Type.Equality
|
||||
import Data.Serialize.Get (getInt8)
|
||||
import Data.Serialize.Put (putInt8)
|
||||
import Data.Type.Equality (TestEquality(..), (:~:)(Refl))
|
||||
import Data.Serialize.Get (Get, getInt8)
|
||||
import Data.Serialize.Put (Putter, PutM, putInt8)
|
||||
import Data.Serializer
|
||||
( Serializer(..)
|
||||
, GetSerializerError
|
||||
, runGetS
|
||||
, runPutS
|
||||
, transformGetError
|
||||
, transformPutError
|
||||
)
|
||||
import Data.Some (Some(..))
|
||||
import GHC.Generics
|
||||
import System.Nix.Store.Remote.Serialize.Prim (getBool, putBool, getEnum, putEnum)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import Test.QuickCheck (Arbitrary(..), oneof)
|
||||
|
||||
@ -274,3 +280,40 @@ cmdSRest = Serializer
|
||||
else lift (putInt8 i)
|
||||
Some (Cmd_Bool b) -> putS opcode OpCode_Bool >> lift (putBool b)
|
||||
}
|
||||
|
||||
-- Primitives helpers
|
||||
|
||||
getInt :: Integral a => Get a
|
||||
getInt = fromIntegral <$> getInt8
|
||||
|
||||
putInt :: Integral a => Putter a
|
||||
putInt = putInt8 . fromIntegral
|
||||
|
||||
-- | Deserialize @Bool@ from integer
|
||||
getBool :: Get Bool
|
||||
getBool = (getInt :: Get Int8) >>= \case
|
||||
0 -> pure False
|
||||
1 -> pure True
|
||||
x -> fail $ "illegal bool value " ++ show x
|
||||
|
||||
-- | Serialize @Bool@ into integer
|
||||
putBool :: Putter Bool
|
||||
putBool True = putInt (1 :: Int8)
|
||||
putBool False = putInt (0 :: Int8)
|
||||
|
||||
-- | Utility toEnum version checking bounds using Bounded class
|
||||
toEnumCheckBounds :: Enum a => Int -> Either String a
|
||||
toEnumCheckBounds = \case
|
||||
x | x < minBound -> Left $ "enum out of min bound " ++ show x
|
||||
x | x > maxBound -> Left $ "enum out of max bound " ++ show x
|
||||
x | otherwise -> Right $ toEnum x
|
||||
|
||||
-- | Deserialize @Enum@ to integer
|
||||
getEnum :: Enum a => Get a
|
||||
getEnum =
|
||||
toEnumCheckBounds <$> getInt
|
||||
>>= either fail pure
|
||||
|
||||
-- | Serialize @Enum@ to integer
|
||||
putEnum :: Enum a => Putter a
|
||||
putEnum = putInt . fromEnum
|
||||
|
@ -1,355 +1,86 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE LiberalTypeSynonyms #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module System.Nix.Store.Remote
|
||||
( addToStore
|
||||
, addTextToStore
|
||||
, addSignatures
|
||||
, addIndirectRoot
|
||||
, addTempRoot
|
||||
, buildPaths
|
||||
, buildDerivation
|
||||
, deleteSpecific
|
||||
, ensurePath
|
||||
, findRoots
|
||||
, isValidPathUncached
|
||||
, queryValidPaths
|
||||
, queryAllValidPaths
|
||||
, querySubstitutablePaths
|
||||
, queryPathInfoUncached
|
||||
, queryReferrers
|
||||
, queryValidDerivers
|
||||
, queryDerivationOutputs
|
||||
, queryDerivationOutputNames
|
||||
, queryPathFromHashPart
|
||||
, queryMissing
|
||||
, optimiseStore
|
||||
, runStore
|
||||
, 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
|
||||
-- * Compat
|
||||
, MonadStore
|
||||
-- * Runners
|
||||
, runStore
|
||||
, runStoreOpts
|
||||
, runStoreOptsTCP
|
||||
) where
|
||||
|
||||
import Crypto.Hash (SHA256)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Dependent.Sum (DSum((:=>)))
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.Map (Map)
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word64)
|
||||
import System.Nix.Nar (NarSource)
|
||||
import System.Nix.Derivation (Derivation)
|
||||
import Data.Default.Class (Default(def))
|
||||
import Network.Socket (Family, SockAddr(SockAddrUnix))
|
||||
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
|
||||
import System.Nix.Build (BuildMode, BuildResult)
|
||||
import System.Nix.Hash (NamedAlgo(..), BaseEncoding(Base16), decodeDigestWith)
|
||||
import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart, InvalidPathError)
|
||||
import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..))
|
||||
|
||||
import qualified Data.Text
|
||||
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 System.Nix.ContentAddress
|
||||
import qualified System.Nix.Hash
|
||||
import qualified System.Nix.Signature
|
||||
import qualified System.Nix.StorePath
|
||||
|
||||
import System.Nix.Store.Remote.MonadStore
|
||||
import System.Nix.Store.Remote.Protocol
|
||||
import System.Nix.Store.Remote.Socket
|
||||
import System.Nix.StorePath (StoreDir)
|
||||
import System.Nix.Store.Remote.MonadStore (RemoteStoreT, getStoreDir, RemoteStoreError(RemoteStoreError_GetAddrInfoFailed))
|
||||
import System.Nix.Store.Remote.Client
|
||||
import System.Nix.Store.Remote.Types
|
||||
|
||||
import Data.Serialize (get)
|
||||
import System.Nix.Store.Remote.Serialize
|
||||
import System.Nix.Store.Remote.Serialize.Prim
|
||||
import qualified Control.Exception
|
||||
import qualified Network.Socket
|
||||
|
||||
-- | 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"
|
||||
-- * Compat
|
||||
|
||||
runOpArgsIO 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
|
||||
type MonadStore = RemoteStoreT StoreConfig IO
|
||||
|
||||
-- | 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"
|
||||
-- * Runners
|
||||
|
||||
storeDir <- getStoreDir
|
||||
runOpArgs AddTextToStore $ do
|
||||
putText name
|
||||
putText text
|
||||
putPaths storeDir references'
|
||||
sockGetPath
|
||||
runStore :: MonadStore a -> Run IO a
|
||||
runStore = runStoreOpts defaultSockPath def
|
||||
where
|
||||
defaultSockPath :: String
|
||||
defaultSockPath = "/nix/var/nix/daemon-socket/socket"
|
||||
|
||||
addSignatures :: StorePath -> [ByteString] -> MonadStore ()
|
||||
addSignatures p signatures = do
|
||||
storeDir <- getStoreDir
|
||||
Control.Monad.void $ simpleOpArgs AddSignatures $ do
|
||||
putPath storeDir p
|
||||
putByteStrings signatures
|
||||
runStoreOpts
|
||||
:: FilePath
|
||||
-> StoreDir
|
||||
-> MonadStore a
|
||||
-> Run IO a
|
||||
runStoreOpts socketPath =
|
||||
runStoreOpts'
|
||||
Network.Socket.AF_UNIX
|
||||
(SockAddrUnix socketPath)
|
||||
|
||||
addIndirectRoot :: StorePath -> MonadStore ()
|
||||
addIndirectRoot pn = do
|
||||
storeDir <- getStoreDir
|
||||
Control.Monad.void $ simpleOpArgs AddIndirectRoot $ putPath storeDir pn
|
||||
runStoreOptsTCP
|
||||
:: String
|
||||
-> Int
|
||||
-> StoreDir
|
||||
-> MonadStore a
|
||||
-> Run IO a
|
||||
runStoreOptsTCP host port sd code = do
|
||||
Network.Socket.getAddrInfo
|
||||
(Just Network.Socket.defaultHints)
|
||||
(Just host)
|
||||
(Just $ show port)
|
||||
>>= \case
|
||||
(sockAddr:_) ->
|
||||
runStoreOpts'
|
||||
(Network.Socket.addrFamily sockAddr)
|
||||
(Network.Socket.addrAddress sockAddr)
|
||||
sd
|
||||
code
|
||||
_ -> pure (Left RemoteStoreError_GetAddrInfoFailed, mempty)
|
||||
|
||||
-- | 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 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 BuildPaths $ do
|
||||
putPaths storeDir ps
|
||||
putInt $ fromEnum bm
|
||||
|
||||
buildDerivation
|
||||
:: StorePath
|
||||
-> Derivation StorePath Text
|
||||
-> BuildMode
|
||||
-> MonadStore BuildResult
|
||||
buildDerivation p drv buildMode = do
|
||||
storeDir <- getStoreDir
|
||||
runOpArgs BuildDerivation $ do
|
||||
putPath storeDir p
|
||||
putDerivation storeDir drv
|
||||
putEnum buildMode
|
||||
-- XXX: reason for this is unknown
|
||||
-- but without it protocol just hangs waiting for
|
||||
-- more data. Needs investigation.
|
||||
-- Intentionally the only warning that should pop-up.
|
||||
putInt (0 :: Int)
|
||||
|
||||
getSocketIncremental get
|
||||
|
||||
-- | Delete store paths
|
||||
deleteSpecific
|
||||
:: HashSet StorePath -- ^ Paths to delete
|
||||
-> MonadStore GCResult
|
||||
deleteSpecific paths = do
|
||||
storeDir <- getStoreDir
|
||||
runOpArgs 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
|
||||
gcResult_deletedPaths <- getPathsOrFail storeDir
|
||||
gcResult_bytesFreed <- getInt
|
||||
-- TODO: who knows
|
||||
_ :: Int <- getInt
|
||||
pure GCResult{..}
|
||||
|
||||
ensurePath :: StorePath -> MonadStore ()
|
||||
ensurePath pn = do
|
||||
storeDir <- getStoreDir
|
||||
Control.Monad.void $ simpleOpArgs EnsurePath $ putPath storeDir pn
|
||||
|
||||
-- | Find garbage collector roots.
|
||||
findRoots :: MonadStore (Map ByteString StorePath)
|
||||
findRoots = do
|
||||
runOp 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 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 QueryValidPaths $ do
|
||||
putPaths storeDir ps
|
||||
putBool $ substitute == SubstituteMode_DoSubstitute
|
||||
sockGetPaths
|
||||
|
||||
queryAllValidPaths :: MonadStore (HashSet StorePath)
|
||||
queryAllValidPaths = do
|
||||
runOp QueryAllValidPaths
|
||||
sockGetPaths
|
||||
|
||||
querySubstitutablePaths :: HashSet StorePath -> MonadStore (HashSet StorePath)
|
||||
querySubstitutablePaths ps = do
|
||||
storeDir <- getStoreDir
|
||||
runOpArgs QuerySubstitutablePaths $ putPaths storeDir ps
|
||||
sockGetPaths
|
||||
|
||||
queryPathInfoUncached :: StorePath -> MonadStore (Metadata StorePath)
|
||||
queryPathInfoUncached path = do
|
||||
storeDir <- getStoreDir
|
||||
runOpArgs QueryPathInfo $ do
|
||||
putPath storeDir path
|
||||
|
||||
valid <- sockGetBool
|
||||
Control.Monad.unless valid $ error "Path is not valid"
|
||||
|
||||
deriverPath <- sockGetPathMay
|
||||
|
||||
narHashText <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr
|
||||
let
|
||||
narHash =
|
||||
case
|
||||
decodeDigestWith @SHA256 Base16 narHashText
|
||||
of
|
||||
Left e -> error e
|
||||
Right d -> System.Nix.Hash.HashAlgo_SHA256 :=> d
|
||||
|
||||
references <- sockGetPaths
|
||||
registrationTime <- sockGet getTime
|
||||
narBytes <- Just <$> sockGetInt
|
||||
ultimate <- sockGetBool
|
||||
|
||||
sigStrings <- fmap Data.Text.Encoding.decodeUtf8 <$> sockGetStrings
|
||||
caString <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr
|
||||
|
||||
let
|
||||
sigs = case
|
||||
Data.Set.fromList <$> mapM (Data.Attoparsec.Text.parseOnly System.Nix.Signature.signatureParser) sigStrings
|
||||
of
|
||||
Left e -> error e
|
||||
Right x -> x
|
||||
|
||||
contentAddress =
|
||||
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
|
||||
|
||||
trust = if ultimate then BuiltLocally else BuiltElsewhere
|
||||
|
||||
pure $ Metadata{..}
|
||||
|
||||
queryReferrers :: StorePath -> MonadStore (HashSet StorePath)
|
||||
queryReferrers p = do
|
||||
storeDir <- getStoreDir
|
||||
runOpArgs QueryReferrers $ putPath storeDir p
|
||||
sockGetPaths
|
||||
|
||||
queryValidDerivers :: StorePath -> MonadStore (HashSet StorePath)
|
||||
queryValidDerivers p = do
|
||||
storeDir <- getStoreDir
|
||||
runOpArgs QueryValidDerivers $ putPath storeDir p
|
||||
sockGetPaths
|
||||
|
||||
queryDerivationOutputs :: StorePath -> MonadStore (HashSet StorePath)
|
||||
queryDerivationOutputs p = do
|
||||
storeDir <- getStoreDir
|
||||
runOpArgs QueryDerivationOutputs $ putPath storeDir p
|
||||
sockGetPaths
|
||||
|
||||
queryDerivationOutputNames :: StorePath -> MonadStore (HashSet StorePath)
|
||||
queryDerivationOutputNames p = do
|
||||
storeDir <- getStoreDir
|
||||
runOpArgs QueryDerivationOutputNames $ putPath storeDir p
|
||||
sockGetPaths
|
||||
|
||||
queryPathFromHashPart :: StorePathHashPart -> MonadStore StorePath
|
||||
queryPathFromHashPart storePathHash = do
|
||||
runOpArgs QueryPathFromHashPart
|
||||
$ putText
|
||||
$ System.Nix.StorePath.storePathHashPartToText storePathHash
|
||||
sockGetPath
|
||||
|
||||
queryMissing
|
||||
:: (HashSet StorePath)
|
||||
-> MonadStore
|
||||
( HashSet StorePath -- Paths that will be built
|
||||
, HashSet StorePath -- Paths that have substitutes
|
||||
, HashSet StorePath -- Unknown paths
|
||||
, Integer -- Download size
|
||||
, Integer -- Nar size?
|
||||
)
|
||||
queryMissing ps = do
|
||||
storeDir <- getStoreDir
|
||||
runOpArgs QueryMissing $ putPaths storeDir ps
|
||||
|
||||
willBuild <- sockGetPaths
|
||||
willSubstitute <- sockGetPaths
|
||||
unknown <- sockGetPaths
|
||||
downloadSize' <- sockGetInt
|
||||
narSize' <- sockGetInt
|
||||
pure (willBuild, willSubstitute, unknown, downloadSize', narSize')
|
||||
|
||||
optimiseStore :: MonadStore ()
|
||||
optimiseStore = Control.Monad.void $ simpleOp OptimiseStore
|
||||
|
||||
syncWithGC :: MonadStore ()
|
||||
syncWithGC = Control.Monad.void $ simpleOp SyncWithGC
|
||||
|
||||
-- returns True on errors
|
||||
verifyStore :: CheckMode -> RepairMode -> MonadStore Bool
|
||||
verifyStore check repair = simpleOpArgs VerifyStore $ do
|
||||
putBool $ check == CheckMode_DoCheck
|
||||
putBool $ repair == RepairMode_DoRepair
|
||||
runStoreOpts'
|
||||
:: Family
|
||||
-> SockAddr
|
||||
-> StoreDir
|
||||
-> MonadStore a
|
||||
-> Run IO a
|
||||
runStoreOpts' sockFamily sockAddr storeRootDir code =
|
||||
Control.Exception.bracket
|
||||
open
|
||||
(Network.Socket.close . hasStoreSocket)
|
||||
(flip runStoreSocket code)
|
||||
where
|
||||
open = do
|
||||
soc <- Network.Socket.socket sockFamily Network.Socket.Stream 0
|
||||
Network.Socket.connect soc sockAddr
|
||||
pure PreStoreConfig
|
||||
{ preStoreConfig_socket = soc
|
||||
, preStoreConfig_dir = storeRootDir
|
||||
}
|
||||
|
@ -3,15 +3,29 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module System.Nix.Store.Remote.Arbitrary where
|
||||
|
||||
import Data.Some (Some(Some))
|
||||
import System.Nix.Arbitrary ()
|
||||
import System.Nix.Store.Types (RepairMode(..))
|
||||
import System.Nix.Store.Remote.Types
|
||||
|
||||
import Test.QuickCheck (Arbitrary(..))
|
||||
import Test.QuickCheck (Arbitrary(..), oneof, suchThat)
|
||||
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
|
||||
import Test.QuickCheck.Instances ()
|
||||
|
||||
deriving via GenericArbitrary CheckMode
|
||||
instance Arbitrary CheckMode
|
||||
|
||||
deriving via GenericArbitrary SubstituteMode
|
||||
instance Arbitrary SubstituteMode
|
||||
|
||||
deriving via GenericArbitrary TestStoreConfig
|
||||
instance Arbitrary TestStoreConfig
|
||||
|
||||
deriving via GenericArbitrary ProtoVersion
|
||||
instance Arbitrary ProtoVersion
|
||||
|
||||
deriving via GenericArbitrary StoreText
|
||||
instance Arbitrary StoreText
|
||||
|
||||
-- * Logger
|
||||
|
||||
deriving via GenericArbitrary Activity
|
||||
@ -26,14 +40,26 @@ deriving via GenericArbitrary ActivityResult
|
||||
deriving via GenericArbitrary Field
|
||||
instance Arbitrary Field
|
||||
|
||||
deriving via GenericArbitrary Trace
|
||||
instance Arbitrary Trace
|
||||
instance Arbitrary Trace where
|
||||
arbitrary = do
|
||||
-- we encode 0 position as Nothing
|
||||
tracePosition <- arbitrary `suchThat` (/= Just 0)
|
||||
traceHint <- arbitrary
|
||||
|
||||
pure Trace{..}
|
||||
|
||||
deriving via GenericArbitrary BasicError
|
||||
instance Arbitrary BasicError
|
||||
|
||||
deriving via GenericArbitrary ErrorInfo
|
||||
instance Arbitrary ErrorInfo
|
||||
instance Arbitrary ErrorInfo where
|
||||
arbitrary = do
|
||||
errorInfoLevel <- arbitrary
|
||||
errorInfoMessage <- arbitrary
|
||||
-- we encode 0 position as Nothing
|
||||
errorInfoPosition <- arbitrary `suchThat` (/= Just 0)
|
||||
errorInfoTraces <- arbitrary
|
||||
|
||||
pure ErrorInfo{..}
|
||||
|
||||
deriving via GenericArbitrary LoggerOpCode
|
||||
instance Arbitrary LoggerOpCode
|
||||
@ -43,3 +69,65 @@ deriving via GenericArbitrary Logger
|
||||
|
||||
deriving via GenericArbitrary Verbosity
|
||||
instance Arbitrary Verbosity
|
||||
|
||||
-- * GC
|
||||
|
||||
deriving via GenericArbitrary GCAction
|
||||
instance Arbitrary GCAction
|
||||
|
||||
deriving via GenericArbitrary GCOptions
|
||||
instance Arbitrary GCOptions
|
||||
|
||||
-- * Handshake
|
||||
|
||||
deriving via GenericArbitrary WorkerMagic
|
||||
instance Arbitrary WorkerMagic
|
||||
|
||||
deriving via GenericArbitrary TrustedFlag
|
||||
instance Arbitrary TrustedFlag
|
||||
|
||||
-- * Worker protocol
|
||||
|
||||
deriving via GenericArbitrary WorkerOp
|
||||
instance Arbitrary WorkerOp
|
||||
|
||||
-- ** Request
|
||||
|
||||
instance Arbitrary (Some StoreRequest) where
|
||||
arbitrary = oneof
|
||||
[ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair)
|
||||
, Some <$> (AddTextToStore <$> arbitrary <*> arbitrary <*> pure RepairMode_DontRepair)
|
||||
, Some <$> (AddSignatures <$> arbitrary <*> arbitrary)
|
||||
, Some . AddIndirectRoot <$> arbitrary
|
||||
, Some . AddTempRoot <$> arbitrary
|
||||
, Some <$> (BuildPaths <$> arbitrary <*> arbitrary)
|
||||
, Some <$> (BuildDerivation <$> arbitrary <*> arbitrary <*> arbitrary)
|
||||
, Some . CollectGarbage <$> arbitrary
|
||||
, Some . EnsurePath <$> arbitrary
|
||||
, pure $ Some FindRoots
|
||||
, Some . IsValidPath <$> arbitrary
|
||||
, Some <$> (QueryValidPaths <$> arbitrary <*> arbitrary)
|
||||
, pure $ Some QueryAllValidPaths
|
||||
, Some . QuerySubstitutablePaths <$> arbitrary
|
||||
, Some . QueryPathInfo <$> arbitrary
|
||||
, Some . QueryReferrers <$> arbitrary
|
||||
, Some . QueryValidDerivers <$> arbitrary
|
||||
, Some . QueryDerivationOutputs <$> arbitrary
|
||||
, Some . QueryDerivationOutputNames <$> arbitrary
|
||||
, Some . QueryPathFromHashPart <$> arbitrary
|
||||
, Some . QueryMissing <$> arbitrary
|
||||
, pure $ Some OptimiseStore
|
||||
, pure $ Some SyncWithGC
|
||||
, Some <$> (VerifyStore <$> arbitrary <*> arbitrary)
|
||||
]
|
||||
|
||||
-- ** Reply
|
||||
|
||||
deriving via GenericArbitrary GCResult
|
||||
instance Arbitrary GCResult
|
||||
|
||||
deriving via GenericArbitrary GCRoot
|
||||
instance Arbitrary GCRoot
|
||||
|
||||
deriving via GenericArbitrary Missing
|
||||
instance Arbitrary Missing
|
||||
|
238
hnix-store-remote/src/System/Nix/Store/Remote/Client.hs
Normal file
238
hnix-store-remote/src/System/Nix/Store/Remote/Client.hs
Normal file
@ -0,0 +1,238 @@
|
||||
module System.Nix.Store.Remote.Client
|
||||
( 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 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.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.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.StoreText (StoreText)
|
||||
import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode)
|
||||
import System.Nix.Store.Remote.Client.Core
|
||||
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
|
||||
|
||||
-- | Add `NarSource` to the store
|
||||
addToStore
|
||||
:: MonadRemoteStore m
|
||||
=> StorePathName -- ^ Name part of the newly created `StorePath`
|
||||
-> NarSource IO -- ^ Provide nar stream
|
||||
-> FileIngestionMethod -- ^ Add target directory recursively
|
||||
-> Some HashAlgo -- ^
|
||||
-> RepairMode -- ^ Only used by local store backend
|
||||
-> m StorePath
|
||||
addToStore name source method hashAlgo repair = do
|
||||
Control.Monad.when
|
||||
(repair == RepairMode_DoRepair)
|
||||
$ throwError RemoteStoreError_RapairNotSupportedByRemoteStore
|
||||
|
||||
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
|
||||
-> Derivation StorePath Text
|
||||
-> BuildMode
|
||||
-> m BuildResult
|
||||
buildDerivation a b c = doReq (BuildDerivation a b c)
|
||||
|
||||
-- | 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)
|
174
hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs
Normal file
174
hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs
Normal file
@ -0,0 +1,174 @@
|
||||
module System.Nix.Store.Remote.Client.Core
|
||||
( Run
|
||||
, runStoreSocket
|
||||
, doReq
|
||||
) where
|
||||
|
||||
import Control.Monad (unless, when)
|
||||
import Control.Monad.Except (throwError)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.DList (DList)
|
||||
import Data.Some (Some(Some))
|
||||
import System.Nix.Nar (NarSource)
|
||||
import System.Nix.Store.Remote.Logger (processOutput)
|
||||
import System.Nix.Store.Remote.MonadStore
|
||||
( MonadRemoteStore
|
||||
, RemoteStoreError(..)
|
||||
, RemoteStoreT
|
||||
, runRemoteStoreT
|
||||
, mapStoreConfig
|
||||
, takeNarSource
|
||||
, getStoreSocket
|
||||
)
|
||||
import System.Nix.Store.Remote.Socket (sockPutS, sockGetS)
|
||||
import System.Nix.Store.Remote.Serializer
|
||||
( bool
|
||||
, int
|
||||
, mapErrorS
|
||||
, protoVersion
|
||||
, storeRequest
|
||||
, text
|
||||
, trustedFlag
|
||||
, workerMagic
|
||||
)
|
||||
import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeInput(..), ClientHandshakeOutput(..))
|
||||
import System.Nix.Store.Remote.Types.Logger (Logger)
|
||||
import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion)
|
||||
import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig)
|
||||
import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))
|
||||
import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..))
|
||||
import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
|
||||
|
||||
import qualified Network.Socket.ByteString
|
||||
|
||||
type Run m a = m (Either RemoteStoreError a, DList Logger)
|
||||
|
||||
-- | Perform @StoreRequest@
|
||||
doReq
|
||||
:: forall m a
|
||||
. ( MonadIO m
|
||||
, MonadRemoteStore m
|
||||
, StoreReply a
|
||||
, Show a
|
||||
)
|
||||
=> StoreRequest a
|
||||
-> m a
|
||||
doReq = \case
|
||||
x -> do
|
||||
sockPutS
|
||||
(mapErrorS
|
||||
RemoteStoreError_SerializerRequest
|
||||
storeRequest
|
||||
)
|
||||
(Some x)
|
||||
|
||||
case x of
|
||||
AddToStore {} -> do
|
||||
|
||||
ms <- takeNarSource
|
||||
case ms of
|
||||
Just (stream :: NarSource IO) -> do
|
||||
soc <- getStoreSocket
|
||||
liftIO
|
||||
$ stream
|
||||
$ Network.Socket.ByteString.sendAll soc
|
||||
Nothing ->
|
||||
throwError
|
||||
RemoteStoreError_NoNarSourceProvided
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
processOutput
|
||||
sockGetS
|
||||
(mapErrorS RemoteStoreError_SerializerReply
|
||||
$ getReplyS @a
|
||||
)
|
||||
|
||||
runStoreSocket
|
||||
:: ( Monad m
|
||||
, MonadIO m
|
||||
)
|
||||
=> PreStoreConfig
|
||||
-> RemoteStoreT StoreConfig m a
|
||||
-> Run m a
|
||||
runStoreSocket preStoreConfig code =
|
||||
runRemoteStoreT preStoreConfig $ do
|
||||
ClientHandshakeOutput{..}
|
||||
<- greet
|
||||
ClientHandshakeInput
|
||||
{ clientHandshakeInputOurVersion = ourProtoVersion
|
||||
}
|
||||
|
||||
mapStoreConfig
|
||||
(preStoreConfigToStoreConfig
|
||||
clientHandshakeOutputLeastCommonVerison)
|
||||
code
|
||||
|
||||
where
|
||||
greet
|
||||
:: MonadIO m
|
||||
=> ClientHandshakeInput
|
||||
-> RemoteStoreT PreStoreConfig m ClientHandshakeOutput
|
||||
greet ClientHandshakeInput{..} = do
|
||||
|
||||
sockPutS
|
||||
(mapErrorS
|
||||
RemoteStoreError_SerializerHandshake
|
||||
workerMagic
|
||||
)
|
||||
WorkerMagic_One
|
||||
|
||||
magic <-
|
||||
sockGetS
|
||||
$ mapErrorS
|
||||
RemoteStoreError_SerializerHandshake
|
||||
workerMagic
|
||||
|
||||
unless
|
||||
(magic == WorkerMagic_Two)
|
||||
$ throwError RemoteStoreError_WorkerMagic2Mismatch
|
||||
|
||||
daemonVersion <- sockGetS protoVersion
|
||||
|
||||
when (daemonVersion < ProtoVersion 1 10)
|
||||
$ throwError RemoteStoreError_ClientVersionTooOld
|
||||
|
||||
sockPutS protoVersion clientHandshakeInputOurVersion
|
||||
|
||||
let leastCommonVersion = min daemonVersion ourProtoVersion
|
||||
|
||||
when (leastCommonVersion >= ProtoVersion 1 14)
|
||||
$ sockPutS int (0 :: Int) -- affinity, obsolete
|
||||
|
||||
when (leastCommonVersion >= ProtoVersion 1 11) $ do
|
||||
sockPutS
|
||||
(mapErrorS RemoteStoreError_SerializerPut bool)
|
||||
False -- reserveSpace, obsolete
|
||||
|
||||
daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33
|
||||
then do
|
||||
-- If we were buffering I/O, we would flush the output here.
|
||||
txtVer <-
|
||||
sockGetS
|
||||
$ mapErrorS
|
||||
RemoteStoreError_SerializerGet
|
||||
text
|
||||
pure $ Just txtVer
|
||||
else pure Nothing
|
||||
|
||||
remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35
|
||||
then do
|
||||
sockGetS
|
||||
$ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag
|
||||
else pure Nothing
|
||||
|
||||
mapStoreConfig
|
||||
(preStoreConfigToStoreConfig leastCommonVersion)
|
||||
processOutput
|
||||
|
||||
pure ClientHandshakeOutput
|
||||
{ clientHandshakeOutputNixVersion = daemonNixVersion
|
||||
, clientHandshakeOutputTrust = remoteTrustsUs
|
||||
, clientHandshakeOutputLeastCommonVerison = leastCommonVersion
|
||||
, clientHandshakeOutputServerVersion = daemonVersion
|
||||
}
|
@ -3,23 +3,25 @@ module System.Nix.Store.Remote.Logger
|
||||
) where
|
||||
|
||||
import Control.Monad.Except (throwError)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Serialize (Result(..))
|
||||
import System.Nix.Store.Remote.Serialize.Prim (putByteString)
|
||||
import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT)
|
||||
import System.Nix.Store.Remote.Socket (sockGet8, sockPut)
|
||||
import System.Nix.Store.Remote.MonadStore (MonadStore, clearData)
|
||||
import System.Nix.Store.Remote.Types (Logger(..), ProtoVersion, hasProtoVersion)
|
||||
import System.Nix.Store.Remote.Socket (sockGet8)
|
||||
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)
|
||||
|
||||
import qualified Control.Monad
|
||||
import qualified Control.Monad.Reader
|
||||
import qualified Control.Monad.State.Strict
|
||||
import qualified Data.Serialize.Get
|
||||
import qualified Data.Serializer
|
||||
import qualified Network.Socket.ByteString
|
||||
|
||||
processOutput :: MonadStore [Logger]
|
||||
processOutput
|
||||
:: MonadRemoteStore m
|
||||
=> m ()
|
||||
processOutput = do
|
||||
protoVersion <- Control.Monad.Reader.asks hasProtoVersion
|
||||
protoVersion <- getProtoVersion
|
||||
sockGet8 >>= go . (decoder protoVersion)
|
||||
where
|
||||
decoder
|
||||
@ -30,38 +32,69 @@ processOutput = do
|
||||
Data.Serialize.Get.runGetPartial
|
||||
(runSerialT protoVersion $ Data.Serializer.getS logger)
|
||||
|
||||
go :: Result (Either LoggerSError Logger) -> MonadStore [Logger]
|
||||
go
|
||||
:: MonadRemoteStore m
|
||||
=> Result (Either LoggerSError Logger)
|
||||
-> m ()
|
||||
go (Done ectrl leftover) = do
|
||||
let loop = do
|
||||
protoVersion <- getProtoVersion
|
||||
sockGet8 >>= go . (decoder protoVersion)
|
||||
|
||||
Control.Monad.unless (leftover == mempty) $
|
||||
-- TODO: throwError
|
||||
error $ "Leftovers detected: '" ++ show leftover ++ "'"
|
||||
throwError
|
||||
$ RemoteStoreError_LoggerLeftovers
|
||||
(show ectrl)
|
||||
leftover
|
||||
|
||||
protoVersion <- Control.Monad.Reader.asks hasProtoVersion
|
||||
case ectrl of
|
||||
-- TODO: tie this with throwError and better error type
|
||||
Left e -> error $ show e
|
||||
Left e -> throwError $ RemoteStoreError_SerializerLogger e
|
||||
Right ctrl -> do
|
||||
case ctrl of
|
||||
e@(Logger_Error _) -> pure [e]
|
||||
Logger_Last -> pure [Logger_Last]
|
||||
Logger_Read _n -> do
|
||||
(mdata, _) <- Control.Monad.State.Strict.get
|
||||
case mdata of
|
||||
Nothing -> throwError "No data to read provided"
|
||||
Just part -> do
|
||||
-- XXX: we should check/assert part size against n of (Read n)
|
||||
sockPut $ putByteString part
|
||||
clearData
|
||||
-- These two terminate the logger loop
|
||||
Logger_Error e -> throwError $ RemoteStoreError_LoggerError e
|
||||
Logger_Last -> appendLog Logger_Last
|
||||
|
||||
sockGet8 >>= go . (decoder protoVersion)
|
||||
-- Read data from source
|
||||
Logger_Read size -> do
|
||||
mSource <- getDataSource
|
||||
case mSource of
|
||||
Nothing ->
|
||||
throwError RemoteStoreError_NoDataSourceProvided
|
||||
Just source -> do
|
||||
mChunk <- liftIO $ source size
|
||||
case mChunk of
|
||||
Nothing -> throwError RemoteStoreError_DataSourceExhausted
|
||||
Just chunk -> do
|
||||
sock <- getStoreSocket
|
||||
liftIO $ Network.Socket.ByteString.sendAll sock chunk
|
||||
|
||||
loop
|
||||
|
||||
-- Write data to sink
|
||||
Logger_Write out -> do
|
||||
mSink <- getDataSink
|
||||
case mSink of
|
||||
Nothing ->
|
||||
throwError RemoteStoreError_NoDataSinkProvided
|
||||
Just sink -> do
|
||||
liftIO $ sink out
|
||||
|
||||
loop
|
||||
|
||||
-- Following we just append and loop
|
||||
-- but listed here explicitely for posterity
|
||||
x@(Logger_Next _) -> appendLog x >> loop
|
||||
x@(Logger_StartActivity {}) -> appendLog x >> loop
|
||||
x@(Logger_StopActivity {}) -> appendLog x >> loop
|
||||
x@(Logger_Result {}) -> appendLog x >> loop
|
||||
|
||||
-- we should probably handle Read here as well
|
||||
x -> do
|
||||
next <- sockGet8 >>= go . (decoder protoVersion)
|
||||
pure $ x : next
|
||||
go (Partial k) = do
|
||||
chunk <- sockGet8
|
||||
go (k chunk)
|
||||
|
||||
go (Fail msg _leftover) = error msg
|
||||
go (Fail msg leftover) =
|
||||
throwError
|
||||
$ RemoteStoreError_LoggerParserFail
|
||||
msg
|
||||
leftover
|
||||
|
@ -1,58 +1,308 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module System.Nix.Store.Remote.MonadStore
|
||||
( MonadStore
|
||||
, mapStoreDir
|
||||
, getStoreDir
|
||||
, getLog
|
||||
, flushLog
|
||||
, gotError
|
||||
, getErrors
|
||||
, setData
|
||||
, clearData
|
||||
( RemoteStoreState(..)
|
||||
, RemoteStoreError(..)
|
||||
, WorkerError(..)
|
||||
, WorkerException(..)
|
||||
, RemoteStoreT
|
||||
, runRemoteStoreT
|
||||
, mapStoreConfig
|
||||
, MonadRemoteStoreR(..)
|
||||
, MonadRemoteStore
|
||||
, getProtoVersion
|
||||
) where
|
||||
|
||||
import Control.Monad.Except (ExceptT)
|
||||
import Control.Monad.Reader (ReaderT, asks)
|
||||
import Control.Monad.Reader.Class (MonadReader)
|
||||
import Control.Monad.State.Strict (StateT, gets, modify)
|
||||
import Control.Exception (SomeException)
|
||||
import Control.Monad.Except (MonadError)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.Reader (MonadReader, ask, asks)
|
||||
import Control.Monad.State.Strict (get, modify)
|
||||
import Control.Monad.Trans (MonadTrans, lift)
|
||||
import Control.Monad.Trans.State.Strict (StateT, runStateT, mapStateT)
|
||||
import Control.Monad.Trans.Except (ExceptT, runExceptT, mapExceptT)
|
||||
import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT)
|
||||
import Data.ByteString (ByteString)
|
||||
|
||||
import Control.Monad.Trans.State.Strict (mapStateT)
|
||||
import Control.Monad.Trans.Except (mapExceptT)
|
||||
import Control.Monad.Trans.Reader (withReaderT)
|
||||
|
||||
import Data.DList (DList)
|
||||
import Data.Word (Word64)
|
||||
import Network.Socket (Socket)
|
||||
import System.Nix.Nar (NarSource)
|
||||
import System.Nix.StorePath (HasStoreDir(..), StoreDir)
|
||||
import System.Nix.Store.Remote.Types.Logger (Logger, isError)
|
||||
import System.Nix.Store.Remote.Types.StoreConfig (StoreConfig(..))
|
||||
import System.Nix.Store.Remote.Serializer (HandshakeSError, LoggerSError, RequestSError, ReplySError, SError)
|
||||
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)
|
||||
|
||||
import qualified Data.DList
|
||||
|
||||
data RemoteStoreState = RemoteStoreState {
|
||||
remoteStoreState_logs :: DList Logger
|
||||
, remoteStoreState_gotError :: Bool
|
||||
, remoteStoreState_mDataSource :: Maybe (Word64 -> IO (Maybe ByteString))
|
||||
-- ^ Source for @Logger_Read@, this will be called repeatedly
|
||||
-- as the daemon requests chunks of size @Word64@.
|
||||
-- If the function returns Nothing and daemon tries to read more
|
||||
-- data an error is thrown.
|
||||
-- Used by @AddToStoreNar@ and @ImportPaths@ operations.
|
||||
, remoteStoreState_mDataSink :: Maybe (ByteString -> IO ())
|
||||
-- ^ Sink for @Logger_Write@, called repeatedly by the daemon
|
||||
-- to dump us some data. Used by @ExportPath@ operation.
|
||||
, remoteStoreState_mNarSource :: Maybe (NarSource IO)
|
||||
}
|
||||
|
||||
data RemoteStoreError
|
||||
= RemoteStoreError_Fixme String
|
||||
| RemoteStoreError_BuildFailed
|
||||
| RemoteStoreError_ClientVersionTooOld
|
||||
| RemoteStoreError_Disconnected
|
||||
| RemoteStoreError_GetAddrInfoFailed
|
||||
| RemoteStoreError_GenericIncrementalLeftovers String ByteString -- when there are bytes left over after genericIncremental parser is done, (Done x leftover), first param is show x
|
||||
| RemoteStoreError_GenericIncrementalFail String ByteString -- when genericIncremental parser returns ((Fail msg leftover) :: Result)
|
||||
| RemoteStoreError_SerializerGet SError
|
||||
| RemoteStoreError_SerializerHandshake HandshakeSError
|
||||
| RemoteStoreError_SerializerLogger LoggerSError
|
||||
| RemoteStoreError_SerializerPut SError
|
||||
| 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
|
||||
| RemoteStoreError_DataSourceExhausted -- remoteStoreState_mDataSource returned Nothing but more data was requested
|
||||
| RemoteStoreError_NoDataSinkProvided -- remoteStoreState_mDataSink is required but it is Nothing
|
||||
| RemoteStoreError_NoNarSourceProvided
|
||||
| RemoteStoreError_OperationFailed
|
||||
| RemoteStoreError_ProtocolMismatch
|
||||
| RemoteStoreError_RapairNotSupportedByRemoteStore -- "repairing is not supported when building through the Nix daemon"
|
||||
| RemoteStoreError_WorkerMagic2Mismatch
|
||||
| RemoteStoreError_WorkerError WorkerError
|
||||
-- bad / redundant
|
||||
| RemoteStoreError_WorkerException WorkerException
|
||||
deriving Show
|
||||
|
||||
-- | fatal error in worker interaction which should disconnect client.
|
||||
data WorkerException
|
||||
= WorkerException_ClientVersionTooOld
|
||||
| WorkerException_ProtocolMismatch
|
||||
| WorkerException_Error WorkerError
|
||||
-- ^ allowed error outside allowed worker state
|
||||
-- | WorkerException_DecodingError DecodingError
|
||||
-- | WorkerException_BuildFailed StorePath
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Non-fatal (to server) errors in worker interaction
|
||||
data WorkerError
|
||||
= WorkerError_SendClosed
|
||||
| WorkerError_InvalidOperation Word64
|
||||
| WorkerError_NotYetImplemented
|
||||
| WorkerError_UnsupportedOperation
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
newtype RemoteStoreT r m a = RemoteStoreT
|
||||
{ _unRemoteStoreT
|
||||
:: ExceptT RemoteStoreError
|
||||
(StateT RemoteStoreState
|
||||
(ReaderT r m)) a
|
||||
}
|
||||
deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadReader r
|
||||
--, MonadState StoreState -- Avoid making the internal state explicit
|
||||
, MonadError RemoteStoreError
|
||||
, MonadIO
|
||||
)
|
||||
|
||||
instance MonadTrans (RemoteStoreT r) where
|
||||
lift = RemoteStoreT . lift . lift . lift
|
||||
|
||||
-- | Runner for @RemoteStoreT@
|
||||
runRemoteStoreT
|
||||
:: ( HasStoreDir r
|
||||
, HasStoreSocket r
|
||||
, Monad m
|
||||
)
|
||||
=> r
|
||||
-> RemoteStoreT r m a
|
||||
-> m (Either RemoteStoreError a, DList Logger)
|
||||
runRemoteStoreT r =
|
||||
fmap (\(res, RemoteStoreState{..}) -> (res, remoteStoreState_logs))
|
||||
. (`runReaderT` r)
|
||||
. (`runStateT` emptyState)
|
||||
. runExceptT
|
||||
. _unRemoteStoreT
|
||||
where
|
||||
emptyState = RemoteStoreState
|
||||
{ remoteStoreState_logs = mempty
|
||||
, remoteStoreState_gotError = False
|
||||
, remoteStoreState_mDataSource = Nothing
|
||||
, remoteStoreState_mDataSink = Nothing
|
||||
, remoteStoreState_mNarSource = Nothing
|
||||
}
|
||||
|
||||
mapStoreConfig
|
||||
:: (rb -> ra)
|
||||
-> (RemoteStoreT ra m a -> RemoteStoreT rb m a)
|
||||
mapStoreConfig f =
|
||||
RemoteStoreT
|
||||
. ( mapExceptT
|
||||
. mapStateT
|
||||
. withReaderT
|
||||
) f
|
||||
. _unRemoteStoreT
|
||||
|
||||
class ( MonadIO m
|
||||
, MonadError RemoteStoreError m
|
||||
, HasStoreSocket r
|
||||
, HasStoreDir r
|
||||
, MonadReader r m
|
||||
)
|
||||
=> MonadRemoteStoreR r m where
|
||||
|
||||
appendLog :: Logger -> m ()
|
||||
default appendLog
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> Logger
|
||||
-> m ()
|
||||
appendLog = lift . appendLog
|
||||
|
||||
getStoreDir :: m StoreDir
|
||||
default getStoreDir
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> m StoreDir
|
||||
getStoreDir = lift getStoreDir
|
||||
|
||||
getStoreSocket :: m Socket
|
||||
default getStoreSocket
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> m Socket
|
||||
getStoreSocket = lift getStoreSocket
|
||||
|
||||
setNarSource :: NarSource IO -> m ()
|
||||
default setNarSource
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> NarSource IO
|
||||
-> m ()
|
||||
setNarSource x = lift (setNarSource x)
|
||||
|
||||
takeNarSource :: m (Maybe (NarSource IO))
|
||||
default takeNarSource
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> m (Maybe (NarSource IO))
|
||||
takeNarSource = lift takeNarSource
|
||||
|
||||
setDataSource :: (Word64 -> IO (Maybe ByteString)) -> m ()
|
||||
default setDataSource
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> (Word64 -> IO (Maybe ByteString))
|
||||
-> m ()
|
||||
setDataSource x = lift (setDataSource x)
|
||||
|
||||
getDataSource :: m (Maybe (Word64 -> IO (Maybe ByteString)))
|
||||
default getDataSource
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> m (Maybe (Word64 -> IO (Maybe ByteString)))
|
||||
getDataSource = lift getDataSource
|
||||
|
||||
clearDataSource :: m ()
|
||||
default clearDataSource
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> m ()
|
||||
clearDataSource = lift clearDataSource
|
||||
|
||||
setDataSink :: (ByteString -> IO ()) -> m ()
|
||||
default setDataSink
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> (ByteString -> IO ())
|
||||
-> m ()
|
||||
setDataSink x = lift (setDataSink x)
|
||||
|
||||
getDataSink :: m (Maybe (ByteString -> IO ()))
|
||||
default getDataSink
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> m (Maybe (ByteString -> IO ()))
|
||||
getDataSink = lift getDataSink
|
||||
|
||||
clearDataSink :: m ()
|
||||
default clearDataSink
|
||||
:: ( MonadTrans t
|
||||
, MonadRemoteStoreR r m'
|
||||
, m ~ t m'
|
||||
)
|
||||
=> m ()
|
||||
clearDataSink = lift clearDataSink
|
||||
|
||||
instance MonadRemoteStoreR r m => MonadRemoteStoreR r (StateT s m)
|
||||
instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ReaderT r m)
|
||||
instance MonadRemoteStoreR r m => MonadRemoteStoreR r (ExceptT RemoteStoreError m)
|
||||
|
||||
type MonadRemoteStore m = MonadRemoteStoreR StoreConfig m
|
||||
|
||||
instance ( MonadIO m
|
||||
, HasStoreDir r
|
||||
, HasStoreSocket r
|
||||
)
|
||||
=> MonadRemoteStoreR r (RemoteStoreT r m) where
|
||||
|
||||
getStoreDir = hasStoreDir <$> RemoteStoreT ask
|
||||
getStoreSocket = hasStoreSocket <$> RemoteStoreT ask
|
||||
|
||||
appendLog x =
|
||||
RemoteStoreT
|
||||
$ modify
|
||||
$ \s -> s { remoteStoreState_logs = remoteStoreState_logs s `Data.DList.snoc` x }
|
||||
|
||||
setDataSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = pure x }
|
||||
getDataSource = remoteStoreState_mDataSource <$> RemoteStoreT get
|
||||
clearDataSource = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSource = Nothing }
|
||||
|
||||
setDataSink x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = pure x }
|
||||
getDataSink = remoteStoreState_mDataSink <$> RemoteStoreT get
|
||||
clearDataSink = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mDataSink = Nothing }
|
||||
|
||||
setNarSource x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mNarSource = pure x }
|
||||
takeNarSource = RemoteStoreT $ do
|
||||
x <- remoteStoreState_mNarSource <$> get
|
||||
modify $ \s -> s { remoteStoreState_mNarSource = Nothing }
|
||||
pure x
|
||||
|
||||
-- | Ask for a @StoreDir@
|
||||
getStoreDir :: (HasStoreDir r, MonadReader r m) => m StoreDir
|
||||
getStoreDir = asks hasStoreDir
|
||||
|
||||
type MonadStore a
|
||||
= ExceptT
|
||||
String
|
||||
(StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
|
||||
a
|
||||
|
||||
-- | For lying about the store dir in tests
|
||||
mapStoreDir :: (StoreDir -> StoreDir) -> (MonadStore a -> MonadStore a)
|
||||
mapStoreDir f = mapExceptT . mapStateT . withReaderT
|
||||
$ \c@StoreConfig { storeConfig_dir = sd } -> c { storeConfig_dir = f sd }
|
||||
|
||||
gotError :: MonadStore Bool
|
||||
gotError = gets (any isError . snd)
|
||||
|
||||
getErrors :: MonadStore [Logger]
|
||||
getErrors = gets (filter isError . snd)
|
||||
|
||||
getLog :: MonadStore [Logger]
|
||||
getLog = gets snd
|
||||
|
||||
flushLog :: MonadStore ()
|
||||
flushLog = modify (\(a, _b) -> (a, []))
|
||||
|
||||
setData :: ByteString -> MonadStore ()
|
||||
setData x = modify (\(_, b) -> (Just x, b))
|
||||
|
||||
clearData :: MonadStore ()
|
||||
clearData = modify (\(_, b) -> (Nothing, b))
|
||||
getProtoVersion
|
||||
:: ( MonadRemoteStoreR r m
|
||||
, HasProtoVersion r
|
||||
)
|
||||
=> m ProtoVersion
|
||||
getProtoVersion = asks hasProtoVersion
|
||||
|
@ -1,154 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module System.Nix.Store.Remote.Protocol
|
||||
( WorkerOp(..)
|
||||
, simpleOp
|
||||
, simpleOpArgs
|
||||
, runOp
|
||||
, runOpArgs
|
||||
, runOpArgsIO
|
||||
, runStore
|
||||
, runStoreOpts
|
||||
, runStoreOptsTCP
|
||||
, runStoreOpts'
|
||||
, ourProtoVersion
|
||||
, GCAction(..)
|
||||
) where
|
||||
|
||||
import qualified Control.Monad
|
||||
import Control.Exception ( bracket )
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader (asks, runReaderT)
|
||||
import Control.Monad.State.Strict
|
||||
|
||||
import Data.Default.Class (Default(def))
|
||||
import qualified Data.Bool
|
||||
import Data.Serialize.Get
|
||||
import Data.Serialize.Put
|
||||
import qualified Data.ByteString
|
||||
|
||||
import Network.Socket (SockAddr(SockAddrUnix))
|
||||
import qualified Network.Socket as S
|
||||
import Network.Socket.ByteString (recv, sendAll)
|
||||
|
||||
import System.Nix.StorePath (StoreDir(..))
|
||||
import System.Nix.Store.Remote.Serialize.Prim
|
||||
import System.Nix.Store.Remote.Logger
|
||||
import System.Nix.Store.Remote.MonadStore
|
||||
import System.Nix.Store.Remote.Socket
|
||||
import System.Nix.Store.Remote.Serializer (protoVersion)
|
||||
import System.Nix.Store.Remote.Types
|
||||
|
||||
ourProtoVersion :: ProtoVersion
|
||||
ourProtoVersion = ProtoVersion
|
||||
{ protoVersion_major = 1
|
||||
, protoVersion_minor = 21
|
||||
}
|
||||
|
||||
workerMagic1 :: Int
|
||||
workerMagic1 = 0x6e697863
|
||||
workerMagic2 :: Int
|
||||
workerMagic2 = 0x6478696f
|
||||
|
||||
defaultSockPath :: String
|
||||
defaultSockPath = "/nix/var/nix/daemon-socket/socket"
|
||||
|
||||
simpleOp :: WorkerOp -> MonadStore Bool
|
||||
simpleOp op = simpleOpArgs op $ pure ()
|
||||
|
||||
simpleOpArgs :: WorkerOp -> Put -> MonadStore Bool
|
||||
simpleOpArgs op args = do
|
||||
runOpArgs op args
|
||||
err <- gotError
|
||||
Data.Bool.bool
|
||||
sockGetBool
|
||||
(do
|
||||
-- TODO: don't use show
|
||||
getErrors >>= throwError . show
|
||||
)
|
||||
err
|
||||
|
||||
runOp :: WorkerOp -> MonadStore ()
|
||||
runOp op = runOpArgs op $ pure ()
|
||||
|
||||
runOpArgs :: WorkerOp -> Put -> MonadStore ()
|
||||
runOpArgs op args =
|
||||
runOpArgsIO
|
||||
op
|
||||
(\encode -> encode $ runPut args)
|
||||
|
||||
runOpArgsIO
|
||||
:: WorkerOp
|
||||
-> ((Data.ByteString.ByteString -> MonadStore ()) -> MonadStore ())
|
||||
-> MonadStore ()
|
||||
runOpArgsIO op encoder = do
|
||||
|
||||
sockPut $ putEnum op
|
||||
|
||||
soc <- asks storeConfig_socket
|
||||
encoder (liftIO . sendAll soc)
|
||||
|
||||
out <- processOutput
|
||||
modify (\(a, b) -> (a, b <> out))
|
||||
err <- gotError
|
||||
Control.Monad.when err $ do
|
||||
-- TODO: don't use show
|
||||
getErrors >>= throwError . show
|
||||
|
||||
runStore :: MonadStore a -> IO (Either String a, [Logger])
|
||||
runStore = runStoreOpts defaultSockPath def
|
||||
|
||||
runStoreOpts
|
||||
:: FilePath -> StoreDir -> MonadStore a -> IO (Either String a, [Logger])
|
||||
runStoreOpts path = runStoreOpts' S.AF_UNIX (SockAddrUnix path)
|
||||
|
||||
runStoreOptsTCP
|
||||
:: String -> Int -> StoreDir -> MonadStore a -> IO (Either String a, [Logger])
|
||||
runStoreOptsTCP host port storeRootDir code = do
|
||||
S.getAddrInfo (Just S.defaultHints) (Just host) (Just $ show port) >>= \case
|
||||
(sockAddr:_) -> runStoreOpts' (S.addrFamily sockAddr) (S.addrAddress sockAddr) storeRootDir code
|
||||
_ -> pure (Left "Couldn't resolve host and port with getAddrInfo.", [])
|
||||
|
||||
runStoreOpts'
|
||||
:: S.Family -> S.SockAddr -> StoreDir -> MonadStore a -> IO (Either String a, [Logger])
|
||||
runStoreOpts' sockFamily sockAddr storeRootDir code =
|
||||
bracket open (S.close . storeConfig_socket) run
|
||||
|
||||
where
|
||||
open = do
|
||||
soc <- S.socket sockFamily S.Stream 0
|
||||
S.connect soc sockAddr
|
||||
pure StoreConfig
|
||||
{ storeConfig_dir = storeRootDir
|
||||
, storeConfig_protoVersion = ourProtoVersion
|
||||
, storeConfig_socket = soc
|
||||
}
|
||||
|
||||
greet = do
|
||||
sockPut $ putInt workerMagic1
|
||||
soc <- asks hasStoreSocket
|
||||
vermagic <- liftIO $ recv soc 16
|
||||
let
|
||||
eres =
|
||||
flip runGet vermagic
|
||||
$ (,)
|
||||
<$> (getInt :: Get Int)
|
||||
<*> (getInt :: Get Int)
|
||||
|
||||
case eres of
|
||||
Left err -> error $ "Error parsing vermagic " ++ err
|
||||
Right (magic2, _daemonProtoVersion) -> do
|
||||
Control.Monad.unless (magic2 == workerMagic2) $ error "Worker magic 2 mismatch"
|
||||
|
||||
pv <- asks hasProtoVersion
|
||||
sockPutS @() protoVersion pv -- clientVersion
|
||||
sockPut $ putInt (0 :: Int) -- affinity
|
||||
sockPut $ putInt (0 :: Int) -- obsolete reserveSpace
|
||||
|
||||
processOutput
|
||||
|
||||
run sock =
|
||||
fmap (\(res, (_data, logs)) -> (res, logs))
|
||||
$ (`runReaderT` sock)
|
||||
$ (`runStateT` (Nothing, []))
|
||||
$ runExceptT (greet >> code)
|
@ -1,208 +0,0 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-|
|
||||
Description : Serialize instances for complex types
|
||||
Maintainer : srk <srk@48.io>
|
||||
|-}
|
||||
module System.Nix.Store.Remote.Serialize where
|
||||
|
||||
import Data.Serialize (Serialize(..))
|
||||
import Data.Serialize.Get (Get)
|
||||
import Data.Serialize.Put (Putter)
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word8, Word32)
|
||||
|
||||
import qualified Control.Monad
|
||||
import qualified Data.Bits
|
||||
import qualified Data.Bool
|
||||
import qualified Data.Map
|
||||
import qualified Data.Set
|
||||
import qualified Data.Text
|
||||
import qualified Data.Vector
|
||||
|
||||
import System.Nix.Derivation (Derivation(..), DerivationOutput(..))
|
||||
import System.Nix.Build (BuildMode(..), BuildStatus(..), BuildResult(..))
|
||||
import System.Nix.StorePath (StoreDir, StorePath)
|
||||
import System.Nix.Store.Remote.Serialize.Prim
|
||||
import System.Nix.Store.Remote.Types
|
||||
|
||||
instance Serialize Text where
|
||||
get = getText
|
||||
put = putText
|
||||
|
||||
-- * BuildResult
|
||||
|
||||
instance Serialize BuildMode where
|
||||
get = getEnum
|
||||
put = putEnum
|
||||
|
||||
instance Serialize BuildStatus where
|
||||
get = getEnum
|
||||
put = putEnum
|
||||
|
||||
instance Serialize BuildResult where
|
||||
get = do
|
||||
status <- get
|
||||
errorMessage <-
|
||||
(\em -> Data.Bool.bool (Just em) Nothing (Data.Text.null em))
|
||||
<$> get
|
||||
timesBuilt <- getInt
|
||||
isNonDeterministic <- getBool
|
||||
startTime <- getTime
|
||||
stopTime <- getTime
|
||||
pure $ BuildResult{..}
|
||||
|
||||
put BuildResult{..} = do
|
||||
put status
|
||||
case errorMessage of
|
||||
Just err -> putText err
|
||||
Nothing -> putText mempty
|
||||
putInt timesBuilt
|
||||
putBool isNonDeterministic
|
||||
putTime startTime
|
||||
putTime stopTime
|
||||
|
||||
-- * GCAction
|
||||
--
|
||||
instance Serialize GCAction where
|
||||
get = getEnum
|
||||
put = putEnum
|
||||
|
||||
-- * ProtoVersion
|
||||
|
||||
-- protoVersion_major & 0xFF00
|
||||
-- protoVersion_minor & 0x00FF
|
||||
instance Serialize ProtoVersion where
|
||||
get = do
|
||||
v <- getInt @Word32
|
||||
pure ProtoVersion
|
||||
{ protoVersion_major = fromIntegral $ Data.Bits.shiftR v 8
|
||||
, protoVersion_minor = fromIntegral $ v Data.Bits..&. 0x00FF
|
||||
}
|
||||
put p =
|
||||
putInt @Word32
|
||||
$ ((Data.Bits.shiftL (fromIntegral $ protoVersion_major p :: Word32) 8)
|
||||
Data.Bits..|. fromIntegral (protoVersion_minor p))
|
||||
|
||||
-- * Derivation
|
||||
|
||||
getDerivation
|
||||
:: StoreDir
|
||||
-> Get (Derivation StorePath Text)
|
||||
getDerivation storeDir = do
|
||||
outputs <-
|
||||
Data.Map.fromList
|
||||
<$> (getMany $ do
|
||||
outputName <- get
|
||||
path <- getPathOrFail storeDir
|
||||
hashAlgo <- get
|
||||
hash <- get
|
||||
pure (outputName, DerivationOutput{..})
|
||||
)
|
||||
|
||||
-- Our type is Derivation, but in Nix
|
||||
-- the type sent over the wire is BasicDerivation
|
||||
-- which omits inputDrvs
|
||||
inputDrvs <- pure mempty
|
||||
inputSrcs <-
|
||||
Data.Set.fromList
|
||||
<$> getMany (getPathOrFail storeDir)
|
||||
|
||||
platform <- get
|
||||
builder <- get
|
||||
args <-
|
||||
Data.Vector.fromList
|
||||
<$> getMany get
|
||||
|
||||
env <-
|
||||
Data.Map.fromList
|
||||
<$> getMany ((,) <$> get <*> get)
|
||||
pure Derivation{..}
|
||||
|
||||
putDerivation :: StoreDir -> Putter (Derivation StorePath Text)
|
||||
putDerivation storeDir Derivation{..} = do
|
||||
flip putMany (Data.Map.toList outputs)
|
||||
$ \(outputName, DerivationOutput{..}) -> do
|
||||
putText outputName
|
||||
putPath storeDir path
|
||||
putText hashAlgo
|
||||
putText hash
|
||||
|
||||
putMany (putPath storeDir) inputSrcs
|
||||
putText platform
|
||||
putText builder
|
||||
putMany putText args
|
||||
|
||||
flip putMany (Data.Map.toList env)
|
||||
$ \(a1, a2) -> putText a1 *> putText a2
|
||||
|
||||
-- * Logger
|
||||
|
||||
instance Serialize Activity where
|
||||
get =
|
||||
toEnumCheckBounds . (+(-100)) <$> getInt
|
||||
>>= either fail pure
|
||||
put = putInt . (+100) . fromEnum
|
||||
|
||||
instance Serialize ActivityID where
|
||||
get = ActivityID <$> getInt
|
||||
put (ActivityID aid) = putInt aid
|
||||
|
||||
instance Serialize ActivityResult where
|
||||
get =
|
||||
toEnumCheckBounds . (+(-100)) <$> getInt
|
||||
>>= either fail pure
|
||||
put = putInt . (+100) . fromEnum
|
||||
|
||||
instance Serialize Field where
|
||||
get = (getInt :: Get Word8) >>= \case
|
||||
0 -> Field_LogInt <$> getInt
|
||||
1 -> Field_LogStr <$> getText
|
||||
x -> fail $ "Unknown log field type: " <> show x
|
||||
put (Field_LogInt x) = putInt (0 :: Word8) >> putInt x
|
||||
put (Field_LogStr x) = putInt (1 :: Word8) >> putText x
|
||||
|
||||
instance Serialize Trace where
|
||||
get = do
|
||||
tracePosition <- (\case 0 -> Nothing; x -> Just x) <$> getInt @Int
|
||||
traceHint <- get
|
||||
pure Trace{..}
|
||||
put Trace{..} = do
|
||||
maybe (putInt @Int 0) putInt $ tracePosition
|
||||
put traceHint
|
||||
|
||||
instance Serialize BasicError where
|
||||
get = do
|
||||
basicErrorMessage <- get
|
||||
basicErrorExitStatus <- getInt
|
||||
pure BasicError{..}
|
||||
put BasicError{..} = do
|
||||
put basicErrorMessage
|
||||
putInt basicErrorExitStatus
|
||||
|
||||
instance Serialize ErrorInfo where
|
||||
get = do
|
||||
etyp <- get @Text
|
||||
Control.Monad.unless (etyp == Data.Text.pack "Error")
|
||||
$ fail
|
||||
$ "get ErrorInfo: received unknown error type" ++ show etyp
|
||||
errorInfoLevel <- get
|
||||
_name <- get @Text -- removed error name
|
||||
errorInfoMessage <- get
|
||||
errorInfoPosition <- (\case 0 -> Nothing; x -> Just x) <$> getInt @Int
|
||||
errorInfoTraces <- getMany get
|
||||
pure ErrorInfo{..}
|
||||
put ErrorInfo{..} = do
|
||||
put $ Data.Text.pack "Error"
|
||||
put errorInfoLevel
|
||||
put $ Data.Text.pack "Error" -- removed error name
|
||||
put errorInfoMessage
|
||||
maybe (putInt @Int 0) putInt $ errorInfoPosition
|
||||
putMany put errorInfoTraces
|
||||
|
||||
instance Serialize LoggerOpCode where
|
||||
get = getInt @Int >>= either fail pure . intToLoggerOpCode
|
||||
put = putInt @Int . loggerOpCodeToInt
|
||||
|
||||
instance Serialize Verbosity where
|
||||
get = getEnum
|
||||
put = putEnum
|
@ -1,215 +0,0 @@
|
||||
{-|
|
||||
Description : Nix-like serialization primitives
|
||||
Maintainer : srk <srk@48.io>
|
||||
|-}
|
||||
module System.Nix.Store.Remote.Serialize.Prim where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Fixed (Uni)
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.Serialize.Get (Get)
|
||||
import Data.Serialize.Put (Putter)
|
||||
import Data.Text (Text)
|
||||
import Data.Time (NominalDiffTime, UTCTime)
|
||||
import Data.Word (Word8)
|
||||
import System.Nix.StorePath (StoreDir, StorePath, InvalidPathError)
|
||||
|
||||
import qualified Control.Monad
|
||||
import qualified Data.Either
|
||||
import qualified Data.HashSet
|
||||
import qualified Data.Serialize.Get
|
||||
import qualified Data.Serialize.Put
|
||||
import qualified Data.ByteString
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified Data.Time.Clock.POSIX
|
||||
import qualified System.Nix.StorePath
|
||||
|
||||
-- * Int
|
||||
|
||||
-- | Deserialize Nix like integer
|
||||
getInt :: Integral a => Get a
|
||||
getInt = fromIntegral <$> Data.Serialize.Get.getWord64le
|
||||
|
||||
-- | Serialize Nix like integer
|
||||
putInt :: Integral a => Putter a
|
||||
putInt = Data.Serialize.Put.putWord64le . fromIntegral
|
||||
|
||||
-- * Bool
|
||||
|
||||
-- | Deserialize @Bool@ from integer
|
||||
getBool :: Get Bool
|
||||
getBool = (getInt :: Get Word8) >>= \case
|
||||
0 -> pure False
|
||||
1 -> pure True
|
||||
x -> fail $ "illegal bool value " ++ show x
|
||||
|
||||
-- | Serialize @Bool@ into integer
|
||||
putBool :: Putter Bool
|
||||
putBool True = putInt (1 :: Int)
|
||||
putBool False = putInt (0 :: Int)
|
||||
|
||||
-- * Enum
|
||||
|
||||
-- | Utility toEnum version checking bounds using Bounded class
|
||||
toEnumCheckBounds :: Enum a => Int -> Either String a
|
||||
toEnumCheckBounds = \case
|
||||
x | x < minBound -> Left $ "enum out of min bound " ++ show x
|
||||
x | x > maxBound -> Left $ "enum out of max bound " ++ show x
|
||||
x | otherwise -> Right $ toEnum x
|
||||
|
||||
-- | Deserialize @Enum@ to integer
|
||||
getEnum :: Enum a => Get a
|
||||
getEnum =
|
||||
toEnumCheckBounds <$> getInt
|
||||
>>= either fail pure
|
||||
|
||||
-- | Serialize @Enum@ to integer
|
||||
putEnum :: Enum a => Putter a
|
||||
putEnum = putInt . fromEnum
|
||||
|
||||
-- * UTCTime
|
||||
|
||||
-- | Deserialize @UTCTime@ from integer
|
||||
-- Only 1 second precision.
|
||||
getTime :: Get UTCTime
|
||||
getTime =
|
||||
Data.Time.Clock.POSIX.posixSecondsToUTCTime
|
||||
. seconds
|
||||
<$> getInt
|
||||
where
|
||||
-- fancy (*10^12), from Int to Uni to Pico(seconds)
|
||||
seconds :: Int -> NominalDiffTime
|
||||
seconds n = realToFrac (toEnum n :: Uni)
|
||||
|
||||
-- | Serialize @UTCTime@ to integer
|
||||
-- Only 1 second precision.
|
||||
putTime :: Putter UTCTime
|
||||
putTime =
|
||||
putInt
|
||||
. seconds
|
||||
. Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds
|
||||
where
|
||||
-- fancy (`div`10^12), from Pico to Uni to Int
|
||||
seconds :: NominalDiffTime -> Int
|
||||
seconds = (fromEnum :: Uni -> Int) . realToFrac
|
||||
|
||||
-- * Combinators
|
||||
|
||||
-- | Deserialize a list
|
||||
getMany :: Get a -> Get [a]
|
||||
getMany parser = do
|
||||
count <- getInt
|
||||
Control.Monad.replicateM count parser
|
||||
|
||||
-- | Serialize a list
|
||||
putMany :: Foldable t => Putter a -> Putter (t a)
|
||||
putMany printer xs = do
|
||||
putInt (length xs)
|
||||
mapM_ printer xs
|
||||
|
||||
-- * ByteString
|
||||
|
||||
-- | Deserialize length prefixed string
|
||||
-- into @ByteString@, checking for correct padding
|
||||
getByteString :: Get ByteString
|
||||
getByteString = do
|
||||
len <- getInt
|
||||
st <- Data.Serialize.Get.getByteString len
|
||||
Control.Monad.when (len `mod` 8 /= 0) $ do
|
||||
pads <- unpad $ fromIntegral $ 8 - (len `mod` 8)
|
||||
Control.Monad.unless
|
||||
(all (== 0) pads)
|
||||
$ fail $ "No zeroes" <> show (st, len, pads)
|
||||
pure st
|
||||
where unpad x = Control.Monad.replicateM x Data.Serialize.Get.getWord8
|
||||
|
||||
-- | Serialize @ByteString@ using length
|
||||
-- prefixed string packing with padding to 8 bytes
|
||||
putByteString :: Putter ByteString
|
||||
putByteString x = do
|
||||
putInt len
|
||||
Data.Serialize.Put.putByteString x
|
||||
Control.Monad.when
|
||||
(len `mod` 8 /= 0)
|
||||
$ pad $ 8 - (len `mod` 8)
|
||||
where
|
||||
len :: Int
|
||||
len = fromIntegral $ Data.ByteString.length x
|
||||
pad count = Control.Monad.replicateM_ count (Data.Serialize.Put.putWord8 0)
|
||||
|
||||
-- | Deserialize a list of @ByteString@s
|
||||
getByteStrings :: Get [ByteString]
|
||||
getByteStrings = getMany getByteString
|
||||
|
||||
-- | Serialize a list of @ByteString@s
|
||||
putByteStrings :: Foldable t => Putter (t ByteString)
|
||||
putByteStrings = putMany putByteString
|
||||
|
||||
-- * Text
|
||||
|
||||
-- | Deserialize @Text@
|
||||
getText :: Get Text
|
||||
getText = Data.Text.Encoding.decodeUtf8 <$> getByteString
|
||||
|
||||
-- | Serialize @Text@
|
||||
putText :: Putter Text
|
||||
putText = putByteString . Data.Text.Encoding.encodeUtf8
|
||||
|
||||
-- | Deserialize a list of @Text@s
|
||||
getTexts :: Get [Text]
|
||||
getTexts = fmap Data.Text.Encoding.decodeUtf8 <$> getByteStrings
|
||||
|
||||
-- | Serialize a list of @Text@s
|
||||
putTexts :: (Functor f, Foldable f) => Putter (f Text)
|
||||
putTexts = putByteStrings . fmap Data.Text.Encoding.encodeUtf8
|
||||
|
||||
-- * StorePath
|
||||
|
||||
-- | Deserialize @StorePath@, checking
|
||||
-- that @StoreDir@ matches expected value
|
||||
getPath :: StoreDir -> Get (Either InvalidPathError StorePath)
|
||||
getPath sd =
|
||||
System.Nix.StorePath.parsePath sd <$> getByteString
|
||||
|
||||
-- | Deserialize @StorePath@, checking
|
||||
-- that @StoreDir@ matches expected value
|
||||
getPathOrFail :: StoreDir -> Get StorePath
|
||||
getPathOrFail sd =
|
||||
getPath sd
|
||||
>>= either
|
||||
(fail . show)
|
||||
pure
|
||||
|
||||
-- | Serialize @StorePath@ with its associated @StoreDir@
|
||||
putPath :: StoreDir -> Putter StorePath
|
||||
putPath storeDir =
|
||||
putByteString
|
||||
. System.Nix.StorePath.storePathToRawFilePath storeDir
|
||||
|
||||
-- | Deserialize a @HashSet@ of @StorePath@s
|
||||
getPaths :: StoreDir -> Get (HashSet (Either InvalidPathError StorePath))
|
||||
getPaths sd =
|
||||
Data.HashSet.fromList
|
||||
. fmap (System.Nix.StorePath.parsePath sd)
|
||||
<$> getByteStrings
|
||||
|
||||
-- | Deserialize @StorePath@, checking
|
||||
-- that @StoreDir@ matches expected value
|
||||
getPathsOrFail :: StoreDir -> Get (HashSet StorePath)
|
||||
getPathsOrFail sd = do
|
||||
eps <-
|
||||
fmap (System.Nix.StorePath.parsePath sd)
|
||||
<$> getByteStrings
|
||||
Control.Monad.when (any Data.Either.isLeft eps)
|
||||
$ fail
|
||||
$ show
|
||||
$ Data.Either.lefts eps
|
||||
pure $ Data.HashSet.fromList $ Data.Either.rights eps
|
||||
|
||||
-- | Serialize a @HashSet@ of @StorePath@s
|
||||
putPaths :: StoreDir -> Putter (HashSet StorePath)
|
||||
putPaths storeDir =
|
||||
putByteStrings
|
||||
. Data.HashSet.toList
|
||||
. Data.HashSet.map
|
||||
(System.Nix.StorePath.storePathToRawFilePath storeDir)
|
File diff suppressed because it is too large
Load Diff
374
hnix-store-remote/src/System/Nix/Store/Remote/Server.hs
Normal file
374
hnix-store-remote/src/System/Nix/Store/Remote/Server.hs
Normal file
@ -0,0 +1,374 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
module System.Nix.Store.Remote.Server where
|
||||
|
||||
import Control.Concurrent.Classy.Async
|
||||
import Control.Monad (join, void, when)
|
||||
import Control.Monad.Conc.Class (MonadConc)
|
||||
import Control.Monad.Except (MonadError, throwError)
|
||||
import Control.Monad.Reader (MonadReader, asks)
|
||||
import Control.Monad.Trans (lift)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.IORef (IORef, atomicModifyIORef, newIORef)
|
||||
import Data.Some (Some(Some))
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void, absurd)
|
||||
import Data.Word (Word32)
|
||||
import qualified Data.Text
|
||||
import qualified Data.Text.IO
|
||||
import Network.Socket (Socket, accept, close, listen, maxListenQueue)
|
||||
import System.Nix.StorePath (StoreDir)
|
||||
import System.Nix.Store.Remote.Serializer as RB
|
||||
import System.Nix.Store.Remote.Socket
|
||||
import System.Nix.Store.Remote.Types.StoreRequest as R
|
||||
import System.Nix.Store.Remote.Types.StoreConfig (HasStoreSocket(..), StoreConfig(..), PreStoreConfig(..), preStoreConfigToStoreConfig)
|
||||
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..))
|
||||
import System.Nix.Store.Remote.Types.Logger (BasicError(..), ErrorInfo, Logger(..))
|
||||
|
||||
import System.Nix.Store.Remote.MonadStore (WorkerError(..), WorkerException(..), RemoteStoreError(..), RemoteStoreT, runRemoteStoreT, mapStoreConfig)
|
||||
import System.Nix.Store.Remote.Types.Handshake (ServerHandshakeInput(..), ServerHandshakeOutput(..))
|
||||
import System.Nix.Store.Remote.Types.ProtoVersion (ourProtoVersion)
|
||||
import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
|
||||
|
||||
type WorkerHelper m = forall a. StoreRequest a -> m a
|
||||
|
||||
-- | Run an emulated nix daemon on given socket address.
|
||||
-- The deamon will close when the continuation returns.
|
||||
runDaemonSocket
|
||||
:: forall m a
|
||||
. ( MonadIO m
|
||||
, MonadConc m
|
||||
, MonadError RemoteStoreError m
|
||||
, MonadReader StoreConfig m
|
||||
)
|
||||
=> StoreDir
|
||||
-> WorkerHelper m
|
||||
-> Socket
|
||||
-> m a
|
||||
-> m a
|
||||
runDaemonSocket sd workerHelper lsock k = do
|
||||
liftIO $ listen lsock maxListenQueue
|
||||
|
||||
liftIO $ Data.Text.IO.putStrLn "listening"
|
||||
|
||||
let listener :: m Void
|
||||
listener = do
|
||||
(sock, _) <- liftIO $ accept lsock
|
||||
liftIO $ Data.Text.IO.putStrLn "accepting"
|
||||
|
||||
let preStoreConfig = PreStoreConfig
|
||||
{ preStoreConfig_socket = sock
|
||||
, preStoreConfig_dir = sd
|
||||
}
|
||||
|
||||
-- TODO: this, but without the space leak
|
||||
fmap fst $ concurrently listener $ processConnection workerHelper preStoreConfig
|
||||
|
||||
either absurd id <$> race listener k
|
||||
|
||||
-- | "main loop" of the daemon for a single connection.
|
||||
--
|
||||
-- this function should take care to not throw errors from client connections.
|
||||
processConnection
|
||||
:: ( MonadIO m
|
||||
, MonadError RemoteStoreError m
|
||||
, MonadReader StoreConfig m
|
||||
)
|
||||
=> WorkerHelper m
|
||||
-> PreStoreConfig
|
||||
-> m ()
|
||||
processConnection workerHelper preStoreConfig = do
|
||||
~() <- void $ runRemoteStoreT preStoreConfig $ do
|
||||
|
||||
ServerHandshakeOutput{..}
|
||||
<- greet
|
||||
ServerHandshakeInput
|
||||
{ serverHandshakeInputNixVersion = "nixVersion (hnix-store-remote)"
|
||||
, serverHandshakeInputOurVersion= ourProtoVersion
|
||||
, serverHandshakeInputTrust = Nothing
|
||||
}
|
||||
|
||||
mapStoreConfig
|
||||
(preStoreConfigToStoreConfig
|
||||
serverHandshakeOutputLeastCommonVersion)
|
||||
$ do
|
||||
|
||||
tunnelLogger <- liftIO $ newTunnelLogger
|
||||
-- Send startup error messages to the client.
|
||||
startWork tunnelLogger
|
||||
|
||||
-- TODO: do we need auth at all? probably?
|
||||
-- If we can't accept clientVersion, then throw an error *here* (not above).
|
||||
--authHook(*store);
|
||||
stopWork tunnelLogger
|
||||
|
||||
-- Process client requests.
|
||||
let loop = do
|
||||
someReq <-
|
||||
sockGetS
|
||||
$ mapErrorS
|
||||
RemoteStoreError_SerializerRequest
|
||||
storeRequest
|
||||
|
||||
lift $ performOp' workerHelper tunnelLogger someReq
|
||||
loop
|
||||
loop
|
||||
|
||||
liftIO $ Data.Text.IO.putStrLn "daemon connection done"
|
||||
liftIO $ close $ preStoreConfig_socket preStoreConfig
|
||||
|
||||
where
|
||||
-- Exchange the greeting.
|
||||
greet
|
||||
:: MonadIO m
|
||||
=> ServerHandshakeInput
|
||||
-> RemoteStoreT PreStoreConfig m ServerHandshakeOutput
|
||||
greet ServerHandshakeInput{..} = do
|
||||
magic <-
|
||||
sockGetS
|
||||
$ mapErrorS
|
||||
RemoteStoreError_SerializerHandshake
|
||||
workerMagic
|
||||
|
||||
liftIO $ print ("magic" :: Text, magic)
|
||||
when (magic /= WorkerMagic_One)
|
||||
$ throwError
|
||||
$ RemoteStoreError_WorkerException
|
||||
WorkerException_ProtocolMismatch
|
||||
|
||||
sockPutS
|
||||
(mapErrorS
|
||||
RemoteStoreError_SerializerHandshake
|
||||
workerMagic
|
||||
)
|
||||
WorkerMagic_Two
|
||||
|
||||
sockPutS protoVersion serverHandshakeInputOurVersion
|
||||
|
||||
clientVersion <- sockGetS protoVersion
|
||||
|
||||
let leastCommonVersion = min clientVersion ourProtoVersion
|
||||
|
||||
liftIO $ print ("Versions client, min" :: Text, clientVersion, leastCommonVersion)
|
||||
|
||||
when (clientVersion < ProtoVersion 1 10)
|
||||
$ throwError
|
||||
$ RemoteStoreError_WorkerException
|
||||
WorkerException_ClientVersionTooOld
|
||||
|
||||
when (clientVersion >= ProtoVersion 1 14) $ do
|
||||
x :: Word32 <- sockGetS int
|
||||
when (x /= 0) $ do
|
||||
-- Obsolete CPU affinity.
|
||||
_ :: Word32 <- sockGetS int
|
||||
pure ()
|
||||
|
||||
when (clientVersion >= ProtoVersion 1 11) $ do
|
||||
_ :: Word32 <- sockGetS int -- obsolete reserveSpace
|
||||
pure ()
|
||||
|
||||
when (clientVersion >= ProtoVersion 1 33) $ do
|
||||
sockPutS
|
||||
(mapErrorS
|
||||
RemoteStoreError_SerializerPut
|
||||
text
|
||||
)
|
||||
serverHandshakeInputNixVersion
|
||||
|
||||
when (clientVersion >= ProtoVersion 1 35) $ do
|
||||
sockPutS
|
||||
(mapErrorS
|
||||
RemoteStoreError_SerializerHandshake
|
||||
trustedFlag
|
||||
)
|
||||
serverHandshakeInputTrust
|
||||
|
||||
pure ServerHandshakeOutput
|
||||
{ serverHandshakeOutputLeastCommonVersion = leastCommonVersion
|
||||
, serverHandshakeOutputClientVersion = clientVersion
|
||||
}
|
||||
|
||||
simpleOp
|
||||
:: ( MonadIO m
|
||||
, HasStoreSocket r
|
||||
, HasProtoVersion r
|
||||
, MonadError RemoteStoreError m
|
||||
, MonadReader r m
|
||||
)
|
||||
=> (StoreRequest () -> m ())
|
||||
-> TunnelLogger r
|
||||
-> m (StoreRequest ())
|
||||
-> m ()
|
||||
simpleOp workerHelper tunnelLogger m = do
|
||||
req <- m
|
||||
bracketLogger tunnelLogger $ workerHelper req
|
||||
sockPutS
|
||||
(mapErrorS
|
||||
RemoteStoreError_SerializerPut
|
||||
bool
|
||||
)
|
||||
True
|
||||
|
||||
simpleOpRet
|
||||
:: ( MonadIO m
|
||||
, HasStoreSocket r
|
||||
, HasProtoVersion r
|
||||
, MonadError RemoteStoreError m
|
||||
, MonadReader r m
|
||||
)
|
||||
=> (StoreRequest a -> m a)
|
||||
-> TunnelLogger r
|
||||
-> NixSerializer r SError a
|
||||
-> m (StoreRequest a)
|
||||
-> m ()
|
||||
simpleOpRet workerHelper tunnelLogger s m = do
|
||||
req <- m
|
||||
resp <- bracketLogger tunnelLogger $ workerHelper req
|
||||
sockPutS
|
||||
(mapErrorS
|
||||
RemoteStoreError_SerializerPut
|
||||
s
|
||||
)
|
||||
resp
|
||||
|
||||
bracketLogger
|
||||
:: ( MonadIO m
|
||||
, HasStoreSocket r
|
||||
, HasProtoVersion r
|
||||
, MonadReader r m
|
||||
, MonadError RemoteStoreError m
|
||||
)
|
||||
=> TunnelLogger r
|
||||
-> m a
|
||||
-> m a
|
||||
bracketLogger tunnelLogger m = do
|
||||
startWork tunnelLogger
|
||||
a <- m
|
||||
stopWork tunnelLogger
|
||||
pure a
|
||||
|
||||
{-# WARNING unimplemented "not yet implemented" #-}
|
||||
unimplemented :: WorkerException
|
||||
unimplemented = WorkerException_Error $ WorkerError_NotYetImplemented
|
||||
|
||||
performOp'
|
||||
:: forall m
|
||||
. ( MonadIO m
|
||||
, MonadError RemoteStoreError m
|
||||
, MonadReader StoreConfig m
|
||||
)
|
||||
=> WorkerHelper m
|
||||
-> TunnelLogger StoreConfig
|
||||
-> Some StoreRequest
|
||||
-> m ()
|
||||
performOp' workerHelper tunnelLogger op = do
|
||||
let _simpleOp' = simpleOp workerHelper tunnelLogger
|
||||
let simpleOpRet'
|
||||
:: NixSerializer StoreConfig SError a
|
||||
-> m (StoreRequest a)
|
||||
-> m ()
|
||||
simpleOpRet' = simpleOpRet workerHelper tunnelLogger
|
||||
|
||||
case op of
|
||||
Some (IsValidPath path) -> simpleOpRet' bool $ do
|
||||
pure $ R.IsValidPath path
|
||||
|
||||
_ -> undefined
|
||||
|
||||
---
|
||||
|
||||
data TunnelLogger r = TunnelLogger
|
||||
{ _tunnelLogger_state :: IORef (TunnelLoggerState r)
|
||||
}
|
||||
|
||||
data TunnelLoggerState r = TunnelLoggerState
|
||||
{ _tunnelLoggerState_canSendStderr :: Bool
|
||||
, _tunnelLoggerState_pendingMsgs :: [Logger]
|
||||
}
|
||||
|
||||
newTunnelLogger :: IO (TunnelLogger r)
|
||||
newTunnelLogger = TunnelLogger <$> newIORef (TunnelLoggerState False [])
|
||||
|
||||
enqueueMsg
|
||||
:: ( MonadIO m
|
||||
, MonadReader r m
|
||||
, MonadError LoggerSError m
|
||||
, HasProtoVersion r
|
||||
, HasStoreSocket r
|
||||
)
|
||||
=> TunnelLogger r
|
||||
-> Logger
|
||||
-> m ()
|
||||
enqueueMsg x l = updateLogger x $ \st@(TunnelLoggerState c p) -> case c of
|
||||
True -> (st, sockPutS logger l)
|
||||
False -> (TunnelLoggerState c (l:p), pure ())
|
||||
|
||||
log
|
||||
:: ( MonadIO m
|
||||
, MonadReader r m
|
||||
, HasStoreSocket r
|
||||
, MonadError LoggerSError m
|
||||
, HasProtoVersion r
|
||||
)
|
||||
=> TunnelLogger r
|
||||
-> Text
|
||||
-> m ()
|
||||
log l s = enqueueMsg l (Logger_Next s)
|
||||
|
||||
startWork
|
||||
:: (MonadIO m, MonadReader r m, HasStoreSocket r
|
||||
|
||||
, MonadError RemoteStoreError m
|
||||
, HasProtoVersion r
|
||||
)
|
||||
=> TunnelLogger r
|
||||
-> m ()
|
||||
startWork x = updateLogger x $ \(TunnelLoggerState _ p) -> (,)
|
||||
(TunnelLoggerState True []) $
|
||||
(traverse_ (sockPutS logger') $ reverse p)
|
||||
where logger' = mapErrorS RemoteStoreError_SerializerLogger logger
|
||||
|
||||
stopWork
|
||||
:: (MonadIO m, MonadReader r m, HasStoreSocket r
|
||||
|
||||
, MonadError RemoteStoreError m
|
||||
, HasProtoVersion r
|
||||
)
|
||||
=> TunnelLogger r
|
||||
-> m ()
|
||||
stopWork x = updateLogger x $ \_ -> (,)
|
||||
(TunnelLoggerState False [])
|
||||
(sockPutS (mapErrorS RemoteStoreError_SerializerLogger logger) Logger_Last)
|
||||
|
||||
-- | Stop sending logging and report an error.
|
||||
--
|
||||
-- Returns true if the the session was in a state that allowed the error to be
|
||||
-- sent.
|
||||
--
|
||||
-- Unlike 'stopWork', this function may be called at any time to (try) to end a
|
||||
-- session with an error.
|
||||
stopWorkOnError
|
||||
:: (MonadIO m, MonadReader r m, HasStoreSocket r, HasProtoVersion r
|
||||
|
||||
, MonadError RemoteStoreError m
|
||||
)
|
||||
=> TunnelLogger r
|
||||
-> ErrorInfo
|
||||
-> m Bool
|
||||
stopWorkOnError x ex = updateLogger x $ \st ->
|
||||
case _tunnelLoggerState_canSendStderr st of
|
||||
False -> (st, pure False)
|
||||
True -> (,) (TunnelLoggerState False []) $ do
|
||||
asks hasProtoVersion >>= \pv -> if protoVersion_minor pv >= 26
|
||||
then sockPutS logger' (Logger_Error (Right ex))
|
||||
else sockPutS logger' (Logger_Error (Left (BasicError 0 (Data.Text.pack $ show ex))))
|
||||
pure True
|
||||
where logger' = mapErrorS RemoteStoreError_SerializerLogger logger
|
||||
|
||||
updateLogger
|
||||
:: (MonadIO m, MonadReader r m, HasStoreSocket r)
|
||||
=> TunnelLogger r
|
||||
-> (TunnelLoggerState r -> (TunnelLoggerState r, m a))
|
||||
-> m a
|
||||
updateLogger x = join . liftIO . atomicModifyIORef (_tunnelLogger_state x)
|
@ -1,23 +1,26 @@
|
||||
module System.Nix.Store.Remote.Socket where
|
||||
|
||||
import Control.Monad.Except (throwError)
|
||||
import Control.Monad.Reader (asks)
|
||||
import Control.Monad.Except (MonadError, throwError)
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Reader (MonadReader, ask, asks)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.Serialize.Get (Get, Result(..))
|
||||
import Data.Serialize.Put
|
||||
import Data.Serialize.Put (Put, runPut)
|
||||
import Network.Socket.ByteString (recv, sendAll)
|
||||
import System.Nix.StorePath (StorePath)
|
||||
import System.Nix.Store.Remote.MonadStore
|
||||
import System.Nix.Store.Remote.Serializer (NixSerializer, runP)
|
||||
import System.Nix.Store.Remote.Serialize.Prim
|
||||
import System.Nix.Store.Remote.Types
|
||||
import System.Nix.Store.Remote.MonadStore (MonadRemoteStoreR, RemoteStoreError(..))
|
||||
import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT)
|
||||
import System.Nix.Store.Remote.Types (HasStoreSocket(..))
|
||||
|
||||
import qualified Control.Exception
|
||||
import qualified Data.ByteString
|
||||
import qualified Data.Serializer
|
||||
import qualified Data.Serialize.Get
|
||||
|
||||
genericIncremental
|
||||
:: MonadIO m
|
||||
:: ( MonadIO m
|
||||
, MonadError RemoteStoreError m
|
||||
, Show a
|
||||
)
|
||||
=> m ByteString
|
||||
-> Get a
|
||||
-> m a
|
||||
@ -25,73 +28,86 @@ genericIncremental getsome parser = do
|
||||
getsome >>= go . decoder
|
||||
where
|
||||
decoder = Data.Serialize.Get.runGetPartial parser
|
||||
go (Done x leftover) | leftover /= mempty =
|
||||
throwError
|
||||
$ RemoteStoreError_GenericIncrementalLeftovers
|
||||
(show x)
|
||||
leftover
|
||||
|
||||
go (Done x _leftover) = pure x
|
||||
|
||||
go (Partial k) = do
|
||||
chunk <- getsome
|
||||
go (k chunk)
|
||||
go (Fail msg _leftover) = error msg
|
||||
|
||||
getSocketIncremental :: Get a -> MonadStore a
|
||||
getSocketIncremental = genericIncremental sockGet8
|
||||
go (Fail msg leftover) =
|
||||
throwError
|
||||
$ RemoteStoreError_GenericIncrementalFail
|
||||
msg
|
||||
leftover
|
||||
|
||||
sockGet8 :: MonadStore ByteString
|
||||
sockGet8
|
||||
:: ( MonadIO m
|
||||
, MonadError RemoteStoreError m
|
||||
, MonadReader r m
|
||||
, HasStoreSocket r
|
||||
)
|
||||
=> m ByteString
|
||||
sockGet8 = do
|
||||
soc <- asks hasStoreSocket
|
||||
liftIO $ recv soc 8
|
||||
eresult <- liftIO $ Control.Exception.try $ recv soc 8
|
||||
case eresult of
|
||||
Left e ->
|
||||
throwError $ RemoteStoreError_IOException e
|
||||
|
||||
sockPut :: Put -> MonadStore ()
|
||||
Right result | Data.ByteString.length result == 0 ->
|
||||
throwError RemoteStoreError_Disconnected
|
||||
|
||||
Right result | otherwise ->
|
||||
pure result
|
||||
|
||||
sockPut
|
||||
:: ( MonadRemoteStoreR r m
|
||||
, HasStoreSocket r
|
||||
)
|
||||
=> Put
|
||||
-> m ()
|
||||
sockPut p = do
|
||||
soc <- asks hasStoreSocket
|
||||
liftIO $ sendAll soc $ runPut p
|
||||
|
||||
sockPutS
|
||||
:: Show e
|
||||
=> NixSerializer ProtoVersion e a
|
||||
:: ( MonadReader r m
|
||||
, MonadError e m
|
||||
, MonadIO m
|
||||
, HasStoreSocket r
|
||||
)
|
||||
=> NixSerializer r e a
|
||||
-> a
|
||||
-> MonadStore ()
|
||||
-> m ()
|
||||
sockPutS s a = do
|
||||
soc <- asks hasStoreSocket
|
||||
pv <- asks hasProtoVersion
|
||||
case runP s pv a of
|
||||
Right x -> liftIO $ sendAll soc x
|
||||
-- TODO: errors
|
||||
Left e -> throwError $ show e
|
||||
r <- ask
|
||||
case runP s r a of
|
||||
Right x -> liftIO $ sendAll (hasStoreSocket r) x
|
||||
Left e -> throwError e
|
||||
|
||||
sockGet :: Get a -> MonadStore a
|
||||
sockGet = getSocketIncremental
|
||||
sockGetS
|
||||
:: forall r e m a
|
||||
. ( HasStoreSocket r
|
||||
, MonadError RemoteStoreError m
|
||||
, MonadError e m
|
||||
, MonadReader r m
|
||||
, MonadIO m
|
||||
, Show a
|
||||
, Show e
|
||||
)
|
||||
=> NixSerializer r e a
|
||||
-> m a
|
||||
sockGetS s = do
|
||||
r <- ask
|
||||
res <- genericIncremental sockGet8
|
||||
$ runSerialT r $ Data.Serializer.getS s
|
||||
|
||||
sockGetInt :: Integral a => MonadStore a
|
||||
sockGetInt = getSocketIncremental getInt
|
||||
|
||||
sockGetBool :: MonadStore Bool
|
||||
sockGetBool = (== (1 :: Int)) <$> sockGetInt
|
||||
|
||||
sockGetStr :: MonadStore ByteString
|
||||
sockGetStr = getSocketIncremental getByteString
|
||||
|
||||
sockGetStrings :: MonadStore [ByteString]
|
||||
sockGetStrings = getSocketIncremental getByteStrings
|
||||
|
||||
sockGetPath :: MonadStore StorePath
|
||||
sockGetPath = do
|
||||
sd <- getStoreDir
|
||||
pth <- getSocketIncremental (getPath sd)
|
||||
either
|
||||
(throwError . show)
|
||||
pure
|
||||
pth
|
||||
|
||||
sockGetPathMay :: MonadStore (Maybe StorePath)
|
||||
sockGetPathMay = do
|
||||
sd <- getStoreDir
|
||||
pth <- getSocketIncremental (getPath sd)
|
||||
pure $
|
||||
either
|
||||
(const Nothing)
|
||||
Just
|
||||
pth
|
||||
|
||||
sockGetPaths :: MonadStore (HashSet StorePath)
|
||||
sockGetPaths = do
|
||||
sd <- getStoreDir
|
||||
getSocketIncremental (getPathsOrFail sd)
|
||||
case res of
|
||||
Right x -> pure x
|
||||
Left e -> throwError e
|
||||
|
@ -4,9 +4,14 @@ module System.Nix.Store.Remote.Types
|
||||
, module System.Nix.Store.Remote.Types.CheckMode
|
||||
, module System.Nix.Store.Remote.Types.Logger
|
||||
, module System.Nix.Store.Remote.Types.ProtoVersion
|
||||
, module System.Nix.Store.Remote.Types.Query
|
||||
, module System.Nix.Store.Remote.Types.StoreConfig
|
||||
, module System.Nix.Store.Remote.Types.StoreRequest
|
||||
, module System.Nix.Store.Remote.Types.StoreText
|
||||
, module System.Nix.Store.Remote.Types.SubstituteMode
|
||||
, module System.Nix.Store.Remote.Types.TrustedFlag
|
||||
, module System.Nix.Store.Remote.Types.Verbosity
|
||||
, module System.Nix.Store.Remote.Types.WorkerMagic
|
||||
, module System.Nix.Store.Remote.Types.WorkerOp
|
||||
) where
|
||||
|
||||
@ -15,7 +20,12 @@ import System.Nix.Store.Remote.Types.GC
|
||||
import System.Nix.Store.Remote.Types.CheckMode
|
||||
import System.Nix.Store.Remote.Types.Logger
|
||||
import System.Nix.Store.Remote.Types.ProtoVersion
|
||||
import System.Nix.Store.Remote.Types.Query
|
||||
import System.Nix.Store.Remote.Types.StoreConfig
|
||||
import System.Nix.Store.Remote.Types.StoreRequest
|
||||
import System.Nix.Store.Remote.Types.StoreText
|
||||
import System.Nix.Store.Remote.Types.SubstituteMode
|
||||
import System.Nix.Store.Remote.Types.TrustedFlag
|
||||
import System.Nix.Store.Remote.Types.Verbosity
|
||||
import System.Nix.Store.Remote.Types.WorkerMagic
|
||||
import System.Nix.Store.Remote.Types.WorkerOp
|
||||
|
@ -6,12 +6,14 @@ module System.Nix.Store.Remote.Types.GC (
|
||||
GCAction(..)
|
||||
, GCOptions(..)
|
||||
, GCResult(..)
|
||||
, GCRoot(..)
|
||||
) where
|
||||
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.Word (Word64)
|
||||
import GHC.Generics (Generic)
|
||||
import System.Nix.StorePath (StorePath)
|
||||
import System.Posix.ByteString (RawFilePath)
|
||||
|
||||
-- | Garbage collection action
|
||||
data GCAction
|
||||
@ -24,24 +26,30 @@ data GCAction
|
||||
-- | Garbage collector operation options
|
||||
data GCOptions = GCOptions
|
||||
{ -- | Operation
|
||||
gcOptions_operation :: GCAction
|
||||
gcOptionsOperation :: GCAction
|
||||
-- | If set, then reachability from the roots is ignored (unused)
|
||||
, gcOptions_ignoreLiveness :: Bool
|
||||
, gcOptionsIgnoreLiveness :: Bool
|
||||
-- | Paths to delete for @GCAction_DeleteSpecific@
|
||||
, gcOptions_pathsToDelete :: HashSet StorePath
|
||||
, gcOptionsPathsToDelete :: HashSet StorePath
|
||||
-- | Stop after `gcOptions_maxFreed` bytes have been freed
|
||||
, gcOptions_maxFreed :: Integer
|
||||
, gcOptionsMaxFreed :: Word64
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
-- | Result of the garbage collection operation
|
||||
data GCResult = GCResult
|
||||
{ -- | Depending on the action, the GC roots,
|
||||
-- or the paths that would be or have been deleted
|
||||
gcResult_deletedPaths :: HashSet StorePath
|
||||
gcResultDeletedPaths :: HashSet StorePath
|
||||
-- | The number of bytes that would be or was freed for
|
||||
--
|
||||
-- - @GCAction_ReturnDead@
|
||||
-- - @GCAction_DeleteDead@
|
||||
-- - @GCAction_DeleteSpecific@
|
||||
, gcResult_bytesFreed :: Word64
|
||||
, gcResultBytesFreed :: Word64
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
-- | Used as a part of the result of @FindRoots@ operation
|
||||
data GCRoot
|
||||
= GCRoot_Censored -- ^ Source path is censored since the user is not trusted
|
||||
| GCRoot_Path RawFilePath -- ^ Raw source path
|
||||
deriving (Eq, Generic, Ord, Show)
|
||||
|
@ -0,0 +1,37 @@
|
||||
module System.Nix.Store.Remote.Types.Handshake
|
||||
( ClientHandshakeInput(..)
|
||||
, ClientHandshakeOutput(..)
|
||||
, ServerHandshakeInput(..)
|
||||
, ServerHandshakeOutput(..)
|
||||
) where
|
||||
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion)
|
||||
import System.Nix.Store.Remote.Types.TrustedFlag (TrustedFlag)
|
||||
|
||||
-- | Data sent by the client during initial protocol handshake
|
||||
data ClientHandshakeInput = ClientHandshakeInput
|
||||
{ clientHandshakeInputOurVersion :: ProtoVersion -- ^ Our protocol version (that we advertise to the server)
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
-- | Data received by the client via initial protocol handshake
|
||||
data ClientHandshakeOutput = ClientHandshakeOutput
|
||||
{ clientHandshakeOutputNixVersion :: Maybe Text -- ^ Textual version, since 1.33
|
||||
, clientHandshakeOutputTrust :: Maybe TrustedFlag -- ^ Whether remote side trusts us
|
||||
, clientHandshakeOutputLeastCommonVerison :: ProtoVersion -- ^ Minimum protocol version supported by both sides
|
||||
, clientHandshakeOutputServerVersion :: ProtoVersion -- ^ Protocol version supported by the server
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
-- | Data sent by the server during initial protocol handshake
|
||||
data ServerHandshakeInput = ServerHandshakeInput
|
||||
{ serverHandshakeInputNixVersion :: Text -- ^ Textual version, since 1.33
|
||||
, serverHandshakeInputOurVersion :: ProtoVersion -- ^ Our protocol version (that we advertise to the client)
|
||||
, serverHandshakeInputTrust :: Maybe TrustedFlag -- ^ Whether client should trusts us
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
-- | Data received by the server during initial protocol handshake
|
||||
data ServerHandshakeOutput = ServerHandshakeOutput
|
||||
{ serverHandshakeOutputLeastCommonVersion :: ProtoVersion -- ^ Minimum protocol version supported by both sides
|
||||
, serverHandshakeOutputClientVersion :: ProtoVersion -- ^ Protocol version supported by the client
|
||||
} deriving (Eq, Generic, Ord, Show)
|
@ -5,13 +5,14 @@ module System.Nix.Store.Remote.Types.Logger
|
||||
, ErrorInfo(..)
|
||||
, Logger(..)
|
||||
, LoggerOpCode(..)
|
||||
, loggerOpCodeToInt
|
||||
, intToLoggerOpCode
|
||||
, loggerOpCodeToWord64
|
||||
, word64ToLoggerOpCode
|
||||
, isError
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word64)
|
||||
import GHC.Generics
|
||||
import System.Nix.Store.Remote.Types.Activity (Activity, ActivityID, ActivityResult)
|
||||
import System.Nix.Store.Remote.Types.Verbosity (Verbosity)
|
||||
@ -55,8 +56,8 @@ data LoggerOpCode
|
||||
| LoggerOpCode_Result
|
||||
deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
loggerOpCodeToInt :: LoggerOpCode -> Int
|
||||
loggerOpCodeToInt = \case
|
||||
loggerOpCodeToWord64 :: LoggerOpCode -> Word64
|
||||
loggerOpCodeToWord64 = \case
|
||||
LoggerOpCode_Next -> 0x6f6c6d67
|
||||
LoggerOpCode_Read -> 0x64617461
|
||||
LoggerOpCode_Write -> 0x64617416
|
||||
@ -66,8 +67,8 @@ loggerOpCodeToInt = \case
|
||||
LoggerOpCode_StopActivity -> 0x53544f50
|
||||
LoggerOpCode_Result -> 0x52534c54
|
||||
|
||||
intToLoggerOpCode :: Int -> Either String LoggerOpCode
|
||||
intToLoggerOpCode = \case
|
||||
word64ToLoggerOpCode :: Word64 -> Either String LoggerOpCode
|
||||
word64ToLoggerOpCode = \case
|
||||
0x6f6c6d67 -> Right LoggerOpCode_Next
|
||||
0x64617461 -> Right LoggerOpCode_Read
|
||||
0x64617416 -> Right LoggerOpCode_Write
|
||||
@ -80,7 +81,7 @@ intToLoggerOpCode = \case
|
||||
|
||||
data Logger
|
||||
= Logger_Next Text
|
||||
| Logger_Read Int -- data needed from source
|
||||
| Logger_Read Word64 -- data needed from source
|
||||
| Logger_Write ByteString -- data for sink
|
||||
| Logger_Last
|
||||
| Logger_Error (Either BasicError ErrorInfo)
|
||||
|
@ -1,6 +1,7 @@
|
||||
module System.Nix.Store.Remote.Types.ProtoVersion
|
||||
( ProtoVersion(..)
|
||||
, HasProtoVersion(..)
|
||||
, ourProtoVersion
|
||||
) where
|
||||
|
||||
import Data.Word (Word8, Word16)
|
||||
@ -17,3 +18,10 @@ class HasProtoVersion r where
|
||||
|
||||
instance HasProtoVersion ProtoVersion where
|
||||
hasProtoVersion = id
|
||||
|
||||
-- | The protocol version we support
|
||||
ourProtoVersion :: ProtoVersion
|
||||
ourProtoVersion = ProtoVersion
|
||||
{ protoVersion_major = 1
|
||||
, protoVersion_minor = 24
|
||||
}
|
||||
|
@ -0,0 +1,5 @@
|
||||
module System.Nix.Store.Remote.Types.Query
|
||||
( module System.Nix.Store.Remote.Types.Query.Missing
|
||||
) where
|
||||
|
||||
import System.Nix.Store.Remote.Types.Query.Missing
|
@ -0,0 +1,18 @@
|
||||
module System.Nix.Store.Remote.Types.Query.Missing
|
||||
( Missing(..)
|
||||
) where
|
||||
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.Word (Word64)
|
||||
import GHC.Generics (Generic)
|
||||
import System.Nix.StorePath (StorePath)
|
||||
|
||||
-- | Result of @QueryMissing@ @StoreRequest@
|
||||
data Missing = Missing
|
||||
{ missingWillBuild :: HashSet StorePath -- ^ Paths that will be built
|
||||
, missingWillSubstitute :: HashSet StorePath -- ^ Paths that can be substituted from cache
|
||||
, missingUnknownPaths :: HashSet StorePath -- ^ Path w/o any information
|
||||
, missingDownloadSize :: Word64 -- ^ Total size of packed NARs to download
|
||||
, missingNarSize :: Word64 -- ^ Total size of NARs after unpacking
|
||||
}
|
||||
deriving (Eq, Generic, Ord, Show)
|
@ -2,15 +2,18 @@
|
||||
module System.Nix.Store.Remote.Types.StoreConfig
|
||||
( PreStoreConfig(..)
|
||||
, StoreConfig(..)
|
||||
, TestStoreConfig(..)
|
||||
, HasStoreSocket(..)
|
||||
, preStoreConfigToStoreConfig
|
||||
) where
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Network.Socket (Socket)
|
||||
import System.Nix.StorePath (HasStoreDir(..), StoreDir)
|
||||
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion)
|
||||
|
||||
data PreStoreConfig = PreStoreConfig
|
||||
{ preStoreConfig_dir :: StoreDir
|
||||
{ preStoreConfig_dir :: StoreDir
|
||||
, preStoreConfig_socket :: Socket
|
||||
}
|
||||
|
||||
@ -27,9 +30,9 @@ instance HasStoreSocket PreStoreConfig where
|
||||
hasStoreSocket = preStoreConfig_socket
|
||||
|
||||
data StoreConfig = StoreConfig
|
||||
{ storeConfig_dir :: StoreDir
|
||||
{ storeConfig_dir :: StoreDir
|
||||
, storeConfig_protoVersion :: ProtoVersion
|
||||
, storeConfig_socket :: Socket
|
||||
, storeConfig_socket :: Socket
|
||||
}
|
||||
|
||||
instance HasStoreDir StoreDir where
|
||||
@ -43,3 +46,27 @@ instance HasProtoVersion StoreConfig where
|
||||
|
||||
instance HasStoreSocket StoreConfig where
|
||||
hasStoreSocket = storeConfig_socket
|
||||
|
||||
data TestStoreConfig = TestStoreConfig
|
||||
{ testStoreConfig_dir :: StoreDir
|
||||
, testStoreConfig_protoVersion :: ProtoVersion
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
instance HasProtoVersion TestStoreConfig where
|
||||
hasProtoVersion = testStoreConfig_protoVersion
|
||||
|
||||
instance HasStoreDir TestStoreConfig where
|
||||
hasStoreDir = testStoreConfig_dir
|
||||
|
||||
-- | Convert @PreStoreConfig@ to @StoreConfig@
|
||||
-- adding @ProtoVersion@ to latter
|
||||
preStoreConfigToStoreConfig
|
||||
:: ProtoVersion
|
||||
-> PreStoreConfig
|
||||
-> StoreConfig
|
||||
preStoreConfigToStoreConfig pv PreStoreConfig{..} =
|
||||
StoreConfig
|
||||
{ storeConfig_dir = preStoreConfig_dir
|
||||
, storeConfig_protoVersion = pv
|
||||
, storeConfig_socket = preStoreConfig_socket
|
||||
}
|
||||
|
@ -0,0 +1,60 @@
|
||||
module System.Nix.Store.Remote.Types.StoreReply
|
||||
( StoreReply(..)
|
||||
) where
|
||||
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.Map (Map)
|
||||
import System.Nix.Build (BuildResult)
|
||||
import System.Nix.StorePath (HasStoreDir(..), StorePath, StorePathName)
|
||||
import System.Nix.StorePath.Metadata (Metadata)
|
||||
import System.Nix.Store.Remote.Serializer
|
||||
import System.Nix.Store.Remote.Types.GC (GCResult, GCRoot)
|
||||
import System.Nix.Store.Remote.Types.Query.Missing (Missing)
|
||||
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion)
|
||||
|
||||
-- | Get @NixSerializer@ for some type @a@
|
||||
-- This could also be generalized for every type
|
||||
-- we have a serializer for but we mostly need
|
||||
-- this for replies and it would make look serializers
|
||||
-- quite hodor, like @a <- getS get; b <- getS get@
|
||||
class StoreReply a where
|
||||
getReplyS
|
||||
:: ( HasStoreDir r
|
||||
, HasProtoVersion r
|
||||
)
|
||||
=> NixSerializer r ReplySError a
|
||||
|
||||
instance StoreReply () where
|
||||
getReplyS = opSuccess
|
||||
|
||||
instance StoreReply Bool where
|
||||
getReplyS = mapPrimE bool
|
||||
|
||||
instance StoreReply BuildResult where
|
||||
getReplyS = buildResult
|
||||
|
||||
instance StoreReply GCResult where
|
||||
getReplyS = gcResult
|
||||
|
||||
instance StoreReply (Map GCRoot StorePath) where
|
||||
getReplyS = mapS gcRoot (mapPrimE storePath)
|
||||
|
||||
instance StoreReply Missing where
|
||||
getReplyS = missing
|
||||
|
||||
instance StoreReply (Maybe (Metadata StorePath)) where
|
||||
getReplyS = maybePathMetadata
|
||||
|
||||
instance StoreReply StorePath where
|
||||
getReplyS = mapPrimE storePath
|
||||
|
||||
instance StoreReply (HashSet StorePath) where
|
||||
getReplyS = mapPrimE (hashSet storePath)
|
||||
|
||||
instance StoreReply (HashSet StorePathName) where
|
||||
getReplyS = mapPrimE (hashSet storePathName)
|
||||
|
||||
mapPrimE
|
||||
:: NixSerializer r SError a
|
||||
-> NixSerializer r ReplySError a
|
||||
mapPrimE = mapErrorS ReplySError_PrimGet
|
@ -0,0 +1,185 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module System.Nix.Store.Remote.Types.StoreRequest
|
||||
( StoreRequest(..)
|
||||
) where
|
||||
|
||||
import Data.GADT.Compare.TH (deriveGEq, deriveGCompare)
|
||||
import Data.GADT.Show.TH (deriveGShow)
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.Kind (Type)
|
||||
import Data.Map (Map)
|
||||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
import Data.Some (Some(Some))
|
||||
|
||||
import System.Nix.Build (BuildMode, BuildResult)
|
||||
import System.Nix.Derivation (Derivation)
|
||||
import System.Nix.DerivedPath (DerivedPath)
|
||||
import System.Nix.Hash (HashAlgo)
|
||||
import System.Nix.Signature (Signature)
|
||||
import System.Nix.Store.Types (FileIngestionMethod, RepairMode)
|
||||
import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart)
|
||||
import System.Nix.StorePath.Metadata (Metadata)
|
||||
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.StoreText (StoreText)
|
||||
import System.Nix.Store.Remote.Types.SubstituteMode (SubstituteMode)
|
||||
|
||||
data StoreRequest :: Type -> Type where
|
||||
-- | Add @NarSource@ to the store.
|
||||
AddToStore
|
||||
:: StorePathName -- ^ Name part of the newly created @StorePath@
|
||||
-> FileIngestionMethod -- ^ Add target directory recursively
|
||||
-> Some HashAlgo -- ^ Nar hashing algorithm
|
||||
-> RepairMode -- ^ Only used by local store backend
|
||||
-> StoreRequest StorePath
|
||||
|
||||
-- | Add text to store.
|
||||
--
|
||||
-- Reference accepts repair but only uses it
|
||||
-- to throw error in case of remote talking to nix-daemon.
|
||||
AddTextToStore
|
||||
:: StoreText
|
||||
-> HashSet StorePath -- ^ Set of @StorePath@s that the added text references
|
||||
-> RepairMode -- ^ Repair mode, must be @RepairMode_DontRepair@ in case of remote backend
|
||||
-> StoreRequest StorePath
|
||||
|
||||
AddSignatures
|
||||
:: StorePath
|
||||
-> Set Signature
|
||||
-> StoreRequest ()
|
||||
|
||||
AddIndirectRoot
|
||||
:: StorePath
|
||||
-> StoreRequest ()
|
||||
|
||||
-- | Add temporary garbage collector root.
|
||||
--
|
||||
-- This root is removed as soon as the client exits.
|
||||
AddTempRoot
|
||||
:: StorePath
|
||||
-> StoreRequest ()
|
||||
|
||||
-- | Build paths if they are an actual derivations.
|
||||
--
|
||||
-- If derivation output paths are already valid, do nothing.
|
||||
BuildPaths
|
||||
:: Set DerivedPath
|
||||
-> BuildMode
|
||||
-> StoreRequest ()
|
||||
|
||||
BuildDerivation
|
||||
:: StorePath
|
||||
-> Derivation StorePath Text
|
||||
-> BuildMode
|
||||
-> StoreRequest BuildResult
|
||||
|
||||
CollectGarbage
|
||||
:: GCOptions
|
||||
-> StoreRequest GCResult
|
||||
|
||||
EnsurePath
|
||||
:: StorePath
|
||||
-> StoreRequest ()
|
||||
|
||||
-- | Find garbage collector roots.
|
||||
FindRoots
|
||||
:: StoreRequest (Map GCRoot StorePath)
|
||||
|
||||
IsValidPath
|
||||
:: StorePath
|
||||
-> StoreRequest Bool
|
||||
|
||||
-- | 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 @SubstituteMode_DoSubstitute@
|
||||
-> StoreRequest (HashSet StorePath)
|
||||
|
||||
QueryAllValidPaths
|
||||
:: StoreRequest (HashSet StorePath)
|
||||
|
||||
QuerySubstitutablePaths
|
||||
:: HashSet StorePath
|
||||
-> StoreRequest (HashSet StorePath)
|
||||
|
||||
QueryPathInfo
|
||||
:: StorePath
|
||||
-> StoreRequest (Maybe (Metadata StorePath))
|
||||
|
||||
QueryReferrers
|
||||
:: StorePath
|
||||
-> StoreRequest (HashSet StorePath)
|
||||
|
||||
QueryValidDerivers
|
||||
:: StorePath
|
||||
-> StoreRequest (HashSet StorePath)
|
||||
|
||||
QueryDerivationOutputs
|
||||
:: StorePath
|
||||
-> StoreRequest (HashSet StorePath)
|
||||
|
||||
QueryDerivationOutputNames
|
||||
:: StorePath
|
||||
-> StoreRequest (HashSet StorePathName)
|
||||
|
||||
QueryPathFromHashPart
|
||||
:: StorePathHashPart
|
||||
-> StoreRequest StorePath
|
||||
|
||||
QueryMissing
|
||||
:: Set DerivedPath
|
||||
-> StoreRequest Missing
|
||||
|
||||
OptimiseStore
|
||||
:: StoreRequest ()
|
||||
|
||||
SyncWithGC
|
||||
:: StoreRequest ()
|
||||
|
||||
-- returns True on errors
|
||||
VerifyStore
|
||||
:: CheckMode
|
||||
-> RepairMode
|
||||
-> StoreRequest Bool
|
||||
|
||||
deriving instance Eq (StoreRequest a)
|
||||
deriving instance Show (StoreRequest a)
|
||||
|
||||
deriveGEq ''StoreRequest
|
||||
deriveGCompare ''StoreRequest
|
||||
deriveGShow ''StoreRequest
|
||||
|
||||
instance {-# OVERLAPPING #-} Eq (Some StoreRequest) where
|
||||
Some (AddToStore a b c d) == Some (AddToStore a' b' c' d') = (a, b, c, d) == (a', b', c', d')
|
||||
Some (AddTextToStore a b c) == Some (AddTextToStore a' b' c') = (a, b, c) == (a', b', c')
|
||||
Some (AddSignatures a b) == Some (AddSignatures a' b') = (a, b) == (a', b')
|
||||
Some (AddIndirectRoot a) == Some (AddIndirectRoot a') = a == a'
|
||||
Some (AddTempRoot a) == Some (AddTempRoot a') = a == a'
|
||||
Some (BuildPaths a b) == Some (BuildPaths a' b') = (a, b) == (a', b')
|
||||
Some (BuildDerivation a b c) == Some (BuildDerivation a' b' c') = (a, b, c) == (a', b', c')
|
||||
Some (CollectGarbage a) == Some (CollectGarbage a') = a == a'
|
||||
Some (EnsurePath a) == Some (EnsurePath a') = a == a'
|
||||
Some (FindRoots) == Some (FindRoots) = True
|
||||
Some (IsValidPath a) == Some (IsValidPath a') = a == a'
|
||||
Some (QueryValidPaths a b) == Some (QueryValidPaths a' b') = (a, b) == (a', b')
|
||||
Some QueryAllValidPaths == Some QueryAllValidPaths = True
|
||||
Some (QuerySubstitutablePaths a) == Some (QuerySubstitutablePaths a') = a == a'
|
||||
Some (QueryPathInfo a) == Some (QueryPathInfo a') = a == a'
|
||||
Some (QueryReferrers a) == Some (QueryReferrers a') = a == a'
|
||||
Some (QueryValidDerivers a) == Some (QueryValidDerivers a') = a == a'
|
||||
Some (QueryDerivationOutputs a) == Some (QueryDerivationOutputs a') = a == a'
|
||||
Some (QueryDerivationOutputNames a) == Some (QueryDerivationOutputNames a') = a == a'
|
||||
Some (QueryPathFromHashPart a) == Some (QueryPathFromHashPart a') = a == a'
|
||||
Some (QueryMissing a) == Some (QueryMissing a') = a == a'
|
||||
Some OptimiseStore == Some OptimiseStore = True
|
||||
Some SyncWithGC == Some SyncWithGC = True
|
||||
Some (VerifyStore a b) == Some (VerifyStore a' b') = (a, b) == (a', b')
|
||||
|
||||
_ == _ = False
|
@ -0,0 +1,12 @@
|
||||
module System.Nix.Store.Remote.Types.StoreText
|
||||
( StoreText(..)
|
||||
) where
|
||||
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
import System.Nix.StorePath (StorePathName)
|
||||
|
||||
data StoreText = StoreText
|
||||
{ storeTextName :: StorePathName
|
||||
, storeTextText :: Text
|
||||
} deriving (Eq, Generic, Ord, Show)
|
@ -0,0 +1,11 @@
|
||||
module System.Nix.Store.Remote.Types.TrustedFlag
|
||||
( TrustedFlag(..)
|
||||
) where
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
-- | Whether remote side trust us
|
||||
data TrustedFlag
|
||||
= TrustedFlag_Trusted
|
||||
| TrustedFlag_NotTrusted
|
||||
deriving (Bounded, Eq, Generic, Enum, Ord, Show)
|
@ -0,0 +1,27 @@
|
||||
module System.Nix.Store.Remote.Types.WorkerMagic
|
||||
( WorkerMagic(..)
|
||||
, workerMagicToWord64
|
||||
, word64ToWorkerMagic
|
||||
) where
|
||||
|
||||
import Data.Word (Word64)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
-- | WorkerMagic
|
||||
--
|
||||
-- Magic numbers exchange during handshake
|
||||
data WorkerMagic
|
||||
= WorkerMagic_One
|
||||
| WorkerMagic_Two
|
||||
deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
workerMagicToWord64 :: WorkerMagic -> Word64
|
||||
workerMagicToWord64 = \case
|
||||
WorkerMagic_One -> 0x6e697863
|
||||
WorkerMagic_Two -> 0x6478696f
|
||||
|
||||
word64ToWorkerMagic :: Word64 -> Either String WorkerMagic
|
||||
word64ToWorkerMagic = \case
|
||||
0x6e697863 -> Right WorkerMagic_One
|
||||
0x6478696f -> Right WorkerMagic_Two
|
||||
x -> Left $ "Invalid WorkerMagic: " ++ show x
|
@ -2,56 +2,58 @@ module System.Nix.Store.Remote.Types.WorkerOp
|
||||
( WorkerOp(..)
|
||||
) where
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
-- | Worker opcode
|
||||
--
|
||||
-- This type has gaps filled in so that the GHC builtin
|
||||
-- Enum instance lands on the right values.
|
||||
data WorkerOp
|
||||
= Reserved_0__ -- 0
|
||||
| IsValidPath -- 1
|
||||
| Reserved_2__ -- 2
|
||||
| HasSubstitutes -- 3
|
||||
| QueryPathHash -- 4 // obsolete
|
||||
| QueryReferences -- 5 // obsolete
|
||||
| QueryReferrers -- 6
|
||||
| AddToStore -- 7
|
||||
| AddTextToStore -- 8 // obsolete since 1.25, Nix 3.0. Use wopAddToStore
|
||||
| BuildPaths -- 9
|
||||
| EnsurePath -- 10 0xa
|
||||
| AddTempRoot -- 11 0xb
|
||||
| AddIndirectRoot -- 12 0xc
|
||||
| SyncWithGC -- 13 0xd
|
||||
| FindRoots -- 14 0xe
|
||||
| Reserved_15__ -- 15 0xf
|
||||
| ExportPath -- 16 0x10 // obsolete
|
||||
| Reserved_17__ -- 17 0x11
|
||||
| QueryDeriver -- 18 0x12 // obsolete
|
||||
| SetOptions -- 19 0x13
|
||||
| CollectGarbage -- 20 0x14
|
||||
| QuerySubstitutablePathInfo -- 21 0x15
|
||||
| QueryDerivationOutputs -- 22 0x16 // obsolete
|
||||
| QueryAllValidPaths -- 23 0x17
|
||||
| QueryFailedPaths -- 24 0x18
|
||||
| ClearFailedPaths -- 25 0x19
|
||||
| QueryPathInfo -- 26 0x1a
|
||||
| ImportPaths -- 27 0x1b // obsolete
|
||||
| QueryDerivationOutputNames -- 28 0x1c // obsolete
|
||||
| QueryPathFromHashPart -- 29 0x1d
|
||||
| QuerySubstitutablePathInfos -- 30 0x1e
|
||||
| QueryValidPaths -- 31 0x1f
|
||||
| QuerySubstitutablePaths -- 32 0x20
|
||||
| QueryValidDerivers -- 33 0x21
|
||||
| OptimiseStore -- 34 0x22
|
||||
| VerifyStore -- 35 0x23
|
||||
| BuildDerivation -- 36 0x24
|
||||
| AddSignatures -- 37 0x25
|
||||
| NarFromPath -- 38 0x26
|
||||
| AddToStoreNar -- 39 0x27
|
||||
| QueryMissing -- 40 0x28
|
||||
| QueryDerivationOutputMap -- 41 0x29
|
||||
| RegisterDrvOutput -- 42 0x2a
|
||||
| QueryRealisation -- 43 0x2b
|
||||
| AddMultipleToStore -- 44 0x2c
|
||||
| AddBuildLog -- 45 0x2d
|
||||
| BuildPathsWithResults -- 46 0x2e
|
||||
deriving (Bounded, Eq, Enum, Ord, Show, Read)
|
||||
= WorkerOp_Reserved_0__ -- 0
|
||||
| WorkerOp_IsValidPath -- 1
|
||||
| WorkerOp_Reserved_2__ -- 2
|
||||
| WorkerOp_HasSubstitutes -- 3
|
||||
| WorkerOp_QueryPathHash -- 4 // obsolete
|
||||
| WorkerOp_QueryReferences -- 5 // obsolete
|
||||
| WorkerOp_QueryReferrers -- 6
|
||||
| WorkerOp_AddToStore -- 7
|
||||
| WorkerOp_AddTextToStore -- 8 // obsolete since 1.25, Nix 3.0. Use wopAddToStore
|
||||
| WorkerOp_BuildPaths -- 9
|
||||
| WorkerOp_EnsurePath -- 10 0xa
|
||||
| WorkerOp_AddTempRoot -- 11 0xb
|
||||
| WorkerOp_AddIndirectRoot -- 12 0xc
|
||||
| WorkerOp_SyncWithGC -- 13 0xd
|
||||
| WorkerOp_FindRoots -- 14 0xe
|
||||
| WorkerOp_Reserved_15__ -- 15 0xf
|
||||
| WorkerOp_ExportPath -- 16 0x10 // obsolete
|
||||
| WorkerOp_Reserved_17__ -- 17 0x11
|
||||
| WorkerOp_QueryDeriver -- 18 0x12 // obsolete
|
||||
| WorkerOp_SetOptions -- 19 0x13
|
||||
| WorkerOp_CollectGarbage -- 20 0x14
|
||||
| WorkerOp_QuerySubstitutablePathInfo -- 21 0x15
|
||||
| WorkerOp_QueryDerivationOutputs -- 22 0x16 // obsolete
|
||||
| WorkerOp_QueryAllValidPaths -- 23 0x17
|
||||
| WorkerOp_QueryFailedPaths -- 24 0x18
|
||||
| WorkerOp_ClearFailedPaths -- 25 0x19
|
||||
| WorkerOp_QueryPathInfo -- 26 0x1a
|
||||
| WorkerOp_ImportPaths -- 27 0x1b // obsolete
|
||||
| WorkerOp_QueryDerivationOutputNames -- 28 0x1c // obsolete
|
||||
| WorkerOp_QueryPathFromHashPart -- 29 0x1d
|
||||
| WorkerOp_QuerySubstitutablePathInfos -- 30 0x1e
|
||||
| WorkerOp_QueryValidPaths -- 31 0x1f
|
||||
| WorkerOp_QuerySubstitutablePaths -- 32 0x20
|
||||
| WorkerOp_QueryValidDerivers -- 33 0x21
|
||||
| WorkerOp_OptimiseStore -- 34 0x22
|
||||
| WorkerOp_VerifyStore -- 35 0x23
|
||||
| WorkerOp_BuildDerivation -- 36 0x24
|
||||
| WorkerOp_AddSignatures -- 37 0x25
|
||||
| WorkerOp_NarFromPath -- 38 0x26
|
||||
| WorkerOp_AddToStoreNar -- 39 0x27
|
||||
| WorkerOp_QueryMissing -- 40 0x28
|
||||
| WorkerOp_QueryDerivationOutputMap -- 41 0x29
|
||||
| WorkerOp_RegisterDrvOutput -- 42 0x2a
|
||||
| WorkerOp_QueryRealisation -- 43 0x2b
|
||||
| WorkerOp_AddMultipleToStore -- 44 0x2c
|
||||
| WorkerOp_AddBuildLog -- 45 0x2d
|
||||
| WorkerOp_BuildPathsWithResults -- 46 0x2e
|
||||
deriving (Bounded, Eq, Enum, Generic, Ord, Show, Read)
|
||||
|
@ -1,9 +0,0 @@
|
||||
import NixDaemon
|
||||
import qualified Spec
|
||||
|
||||
-- we run remote tests in
|
||||
-- Linux namespaces to avoid interacting with systems store
|
||||
main :: IO ()
|
||||
main = do
|
||||
enterNamespaces
|
||||
Spec.main
|
12
hnix-store-remote/tests-io/Main.hs
Normal file
12
hnix-store-remote/tests-io/Main.hs
Normal file
@ -0,0 +1,12 @@
|
||||
module Main where
|
||||
|
||||
import qualified Test.Hspec
|
||||
import qualified NixDaemonSpec
|
||||
|
||||
-- we run remote tests in
|
||||
-- Linux namespaces to avoid interacting with systems store
|
||||
main :: IO ()
|
||||
main = do
|
||||
NixDaemonSpec.enterNamespaces
|
||||
Test.Hspec.hspec
|
||||
NixDaemonSpec.spec
|
@ -1,291 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module NixDaemon where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.Either (isRight, isLeft)
|
||||
import Data.Bool (bool)
|
||||
import Control.Monad (forM_, void)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified System.Environment
|
||||
import Control.Exception (bracket)
|
||||
import Control.Concurrent (threadDelay)
|
||||
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.Text
|
||||
import qualified Data.Text.Encoding
|
||||
import System.Directory
|
||||
import System.IO.Temp
|
||||
import qualified System.Process as P
|
||||
import System.Posix.User as U
|
||||
import System.Linux.Namespaces as NS
|
||||
import Test.Hspec (Spec, describe, context)
|
||||
import qualified Test.Hspec as Hspec
|
||||
import Test.Hspec.Expectations.Lifted
|
||||
import System.FilePath
|
||||
import System.Nix.Build
|
||||
import System.Nix.StorePath
|
||||
import System.Nix.StorePath.Metadata
|
||||
import System.Nix.Store.Remote
|
||||
import System.Nix.Store.Remote.Protocol
|
||||
|
||||
import Crypto.Hash (SHA256)
|
||||
import System.Nix.Nar (dumpPath)
|
||||
|
||||
createProcessEnv :: FilePath -> String -> [String] -> IO P.ProcessHandle
|
||||
createProcessEnv fp proc args = do
|
||||
mPath <- System.Environment.lookupEnv "PATH"
|
||||
|
||||
(_, _, _, ph) <-
|
||||
P.createProcess (P.proc proc args)
|
||||
{ P.cwd = Just fp
|
||||
, P.env = Just $ mockedEnv mPath fp
|
||||
}
|
||||
pure ph
|
||||
|
||||
mockedEnv :: Maybe String -> FilePath -> [(String, FilePath)]
|
||||
mockedEnv mEnvPath fp =
|
||||
[ ("NIX_STORE_DIR" , fp </> "store")
|
||||
, ("NIX_LOCALSTATE_DIR", fp </> "var")
|
||||
, ("NIX_LOG_DIR" , fp </> "var" </> "log")
|
||||
, ("NIX_STATE_DIR" , fp </> "var" </> "nix")
|
||||
, ("NIX_CONF_DIR" , fp </> "etc")
|
||||
, ("HOME" , fp </> "home")
|
||||
-- , ("NIX_REMOTE", "daemon")
|
||||
] <> foldMap (\x -> [("PATH", x)]) mEnvPath
|
||||
|
||||
waitSocket :: FilePath -> Int -> IO ()
|
||||
waitSocket _ 0 = fail "No socket"
|
||||
waitSocket fp x = do
|
||||
ex <- doesFileExist fp
|
||||
bool
|
||||
(threadDelay 100000 >> waitSocket fp (x - 1))
|
||||
(pure ())
|
||||
ex
|
||||
|
||||
writeConf :: FilePath -> IO ()
|
||||
writeConf fp =
|
||||
writeFile fp $ unlines
|
||||
[ "build-users-group = "
|
||||
, "trusted-users = root"
|
||||
, "allowed-users = *"
|
||||
, "fsync-metadata = false"
|
||||
]
|
||||
|
||||
{-
|
||||
- we run in user namespace as root but groups are failed
|
||||
- => build-users-group has to be empty but we still
|
||||
- get an error (maybe older nix-daemon)
|
||||
-
|
||||
uid=0(root) gid=65534(nobody) groups=65534(nobody)
|
||||
|
||||
drwxr-xr-x 3 0 65534 60 Nov 29 05:53 store
|
||||
|
||||
accepted connection from pid 22959, user root (trusted)
|
||||
error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e5616122/store': Invalid argument
|
||||
-}
|
||||
|
||||
startDaemon
|
||||
:: FilePath
|
||||
-> IO (P.ProcessHandle, MonadStore a -> IO (Either String a, [Logger]))
|
||||
startDaemon fp = do
|
||||
writeConf (fp </> "etc" </> "nix.conf")
|
||||
p <- createProcessEnv fp "nix-daemon" []
|
||||
waitSocket sockFp 30
|
||||
pure (p, runStoreOpts sockFp (StoreDir $ BSC.pack $ fp </> "store"))
|
||||
where
|
||||
sockFp = fp </> "var/nix/daemon-socket/socket"
|
||||
|
||||
enterNamespaces :: IO ()
|
||||
enterNamespaces = do
|
||||
uid <- getEffectiveUserID
|
||||
gid <- getEffectiveGroupID
|
||||
|
||||
unshare [User, Network, Mount]
|
||||
-- fmap our (parent) uid to root
|
||||
writeUserMappings Nothing [UserMapping 0 uid 1]
|
||||
-- fmap our (parent) gid to root group
|
||||
writeGroupMappings Nothing [GroupMapping 0 gid 1] True
|
||||
|
||||
withNixDaemon
|
||||
:: ((MonadStore a -> IO (Either String a, [Logger])) -> IO a) -> IO a
|
||||
withNixDaemon action =
|
||||
withSystemTempDirectory "test-nix-store" $ \path -> do
|
||||
|
||||
mapM_ (createDirectory . snd)
|
||||
(filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path)
|
||||
|
||||
ini <- createProcessEnv path "nix-store" ["--init"]
|
||||
void $ P.waitForProcess ini
|
||||
|
||||
writeFile (path </> "dummy") "Hello World"
|
||||
|
||||
setCurrentDirectory path
|
||||
|
||||
bracket (startDaemon path)
|
||||
(P.terminateProcess . fst)
|
||||
(action . snd)
|
||||
|
||||
checks :: (Show a, Show b) => IO (a, b) -> (a -> Bool) -> IO ()
|
||||
checks action check = action >>= (`Hspec.shouldSatisfy` (check . fst))
|
||||
|
||||
it
|
||||
:: (Show a, Show b, Monad m)
|
||||
=> String
|
||||
-> m c
|
||||
-> (a -> Bool)
|
||||
-> Hspec.SpecWith (m () -> IO (a, b))
|
||||
it name action check =
|
||||
Hspec.it name $ \run -> run (void $ action) `checks` check
|
||||
|
||||
itRights
|
||||
:: (Show a, Show b, Show c, Monad m)
|
||||
=> String
|
||||
-> m d
|
||||
-> Hspec.SpecWith (m () -> IO (Either a b, c))
|
||||
itRights name action = it name action isRight
|
||||
|
||||
itLefts
|
||||
:: (Show a, Show b, Show c, Monad m)
|
||||
=> String
|
||||
-> m d
|
||||
-> Hspec.SpecWith (m () -> IO (Either a b, c))
|
||||
itLefts name action = it name action isLeft
|
||||
|
||||
withPath :: (StorePath -> MonadStore a) -> MonadStore a
|
||||
withPath action = do
|
||||
path <- addTextToStore "hnix-store" "test" mempty RepairMode_DontRepair
|
||||
action path
|
||||
|
||||
-- | dummy path, adds <tmp>/dummpy with "Hello World" contents
|
||||
dummy :: MonadStore StorePath
|
||||
dummy = do
|
||||
let name = Data.Either.fromRight (error "impossible") $ makeStorePathName "dummy"
|
||||
addToStore @SHA256 name (dumpPath "dummy") FileIngestionMethod_Flat RepairMode_DontRepair
|
||||
|
||||
invalidPath :: StorePath
|
||||
invalidPath =
|
||||
let name = Data.Either.fromRight (error "impossible") $ makeStorePathName "invalid"
|
||||
in unsafeMakeStorePath (mkStorePathHashPart @SHA256 "invalid") name
|
||||
|
||||
withBuilder :: (StorePath -> MonadStore a) -> MonadStore a
|
||||
withBuilder action = do
|
||||
path <- addTextToStore "builder" builderSh mempty RepairMode_DontRepair
|
||||
action path
|
||||
|
||||
builderSh :: Text
|
||||
builderSh = "declare -xpexport > $out"
|
||||
|
||||
spec_protocol :: Spec
|
||||
spec_protocol = Hspec.around withNixDaemon $
|
||||
|
||||
describe "store" $ do
|
||||
|
||||
context "syncWithGC" $
|
||||
itRights "syncs with garbage collector" syncWithGC
|
||||
|
||||
context "verifyStore" $ do
|
||||
itRights "check=False repair=False" $
|
||||
verifyStore
|
||||
CheckMode_DontCheck
|
||||
RepairMode_DontRepair
|
||||
`shouldReturn` False
|
||||
|
||||
itRights "check=True repair=False" $
|
||||
verifyStore
|
||||
CheckMode_DoCheck
|
||||
RepairMode_DontRepair
|
||||
`shouldReturn` False
|
||||
|
||||
--privileged
|
||||
itRights "check=True repair=True" $
|
||||
verifyStore
|
||||
CheckMode_DoCheck
|
||||
RepairMode_DoRepair
|
||||
`shouldReturn` False
|
||||
|
||||
context "addTextToStore" $
|
||||
itRights "adds text to store" $ withPath pure
|
||||
|
||||
context "isValidPathUncached" $ do
|
||||
itRights "validates path" $ withPath $ \path -> do
|
||||
liftIO $ print path
|
||||
isValidPathUncached path `shouldReturn` True
|
||||
itLefts "fails on invalid path" $ mapStoreDir (\_ -> StoreDir "/asdf") $ isValidPathUncached invalidPath
|
||||
|
||||
context "queryAllValidPaths" $ do
|
||||
itRights "empty query" queryAllValidPaths
|
||||
itRights "non-empty query" $ withPath $ \path ->
|
||||
queryAllValidPaths `shouldReturn` HS.fromList [path]
|
||||
|
||||
context "queryPathInfoUncached" $
|
||||
itRights "queries path info" $ withPath $ \path -> do
|
||||
meta <- queryPathInfoUncached path
|
||||
references meta `shouldSatisfy` HS.null
|
||||
|
||||
context "ensurePath" $
|
||||
itRights "simple ensure" $ withPath ensurePath
|
||||
|
||||
context "addTempRoot" $
|
||||
itRights "simple addition" $ withPath addTempRoot
|
||||
|
||||
context "addIndirectRoot" $
|
||||
itRights "simple addition" $ withPath addIndirectRoot
|
||||
|
||||
context "buildPaths" $ do
|
||||
itRights "build Normal" $ withPath $ \path -> do
|
||||
let pathSet = HS.fromList [path]
|
||||
buildPaths pathSet BuildMode_Normal
|
||||
|
||||
itRights "build Check" $ withPath $ \path -> do
|
||||
let pathSet = HS.fromList [path]
|
||||
buildPaths pathSet BuildMode_Check
|
||||
|
||||
itLefts "build Repair" $ withPath $ \path -> do
|
||||
let pathSet = HS.fromList [path]
|
||||
buildPaths pathSet BuildMode_Repair
|
||||
|
||||
context "roots" $ context "findRoots" $ do
|
||||
itRights "empty roots" (findRoots `shouldReturn` M.empty)
|
||||
|
||||
itRights "path added as a temp root" $ withPath $ \_ -> do
|
||||
roots <- findRoots
|
||||
roots `shouldSatisfy` ((== 1) . M.size)
|
||||
|
||||
context "optimiseStore" $ itRights "optimises" optimiseStore
|
||||
|
||||
context "queryMissing" $
|
||||
itRights "queries" $ withPath $ \path -> do
|
||||
let pathSet = HS.fromList [path]
|
||||
queryMissing pathSet `shouldReturn` (HS.empty, HS.empty, HS.empty, 0, 0)
|
||||
|
||||
context "addToStore" $
|
||||
itRights "adds file to store" $ do
|
||||
fp <- liftIO $ writeSystemTempFile "addition" "lal"
|
||||
let name = Data.Either.fromRight (error "impossible") $ makeStorePathName "tmp-addition"
|
||||
res <- addToStore @SHA256 name (dumpPath fp) FileIngestionMethod_Flat RepairMode_DontRepair
|
||||
liftIO $ print res
|
||||
|
||||
context "with dummy" $ do
|
||||
itRights "adds dummy" dummy
|
||||
|
||||
itRights "valid dummy" $ do
|
||||
path <- dummy
|
||||
liftIO $ print path
|
||||
isValidPathUncached path `shouldReturn` True
|
||||
|
||||
context "deleteSpecific" $
|
||||
itRights "delete a 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/" ]
|
||||
tempRootList <- liftIO $ listDirectory tempRootsDir
|
||||
liftIO $ forM_ tempRootList $ \entry -> do
|
||||
removeFile $ mconcat [ tempRootsDir, "/", entry ]
|
||||
|
||||
GCResult{..} <- deleteSpecific (HS.fromList [path])
|
||||
gcResult_deletedPaths `shouldBe` HS.fromList [path]
|
||||
gcResult_bytesFreed `shouldBe` 4
|
||||
|
397
hnix-store-remote/tests-io/NixDaemonSpec.hs
Normal file
397
hnix-store-remote/tests-io/NixDaemonSpec.hs
Normal file
@ -0,0 +1,397 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module NixDaemonSpec
|
||||
( enterNamespaces
|
||||
, spec
|
||||
) where
|
||||
|
||||
import Control.Monad (forM_, unless, void)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Crypto.Hash (SHA256)
|
||||
import Data.Some (Some(Some))
|
||||
import Data.Text (Text)
|
||||
import Test.Hspec (Spec, SpecWith, around, describe, context)
|
||||
import Test.Hspec.Expectations.Lifted
|
||||
import Test.Hspec.Nix (forceRight)
|
||||
import System.FilePath ((</>))
|
||||
import System.Linux.Namespaces (Namespace(..), GroupMapping(..), UserMapping(..))
|
||||
import System.Nix.Hash (HashAlgo(HashAlgo_SHA256))
|
||||
import System.Nix.Build (BuildMode(..))
|
||||
import System.Nix.DerivedPath (DerivedPath(..))
|
||||
import System.Nix.StorePath (StoreDir(..), StorePath)
|
||||
import System.Nix.StorePath.Metadata (Metadata(..))
|
||||
import System.Nix.Store.Remote
|
||||
import System.Nix.Store.Remote.MonadStore (MonadRemoteStore)
|
||||
import System.Process (CreateProcess(..), ProcessHandle)
|
||||
import qualified Control.Concurrent
|
||||
import qualified Control.Exception
|
||||
import qualified Data.ByteString.Char8
|
||||
import qualified Data.Either
|
||||
import qualified Data.HashSet
|
||||
import qualified Data.Map
|
||||
import qualified Data.Set
|
||||
import qualified Data.Text
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified System.Directory
|
||||
import qualified System.Environment
|
||||
import qualified System.IO.Temp
|
||||
import qualified System.Linux.Namespaces
|
||||
import qualified System.Nix.StorePath
|
||||
import qualified System.Nix.Nar
|
||||
import qualified System.Nix.Store.Remote.MonadStore
|
||||
import qualified System.Posix.User
|
||||
import qualified System.Process
|
||||
import qualified Test.Hspec
|
||||
|
||||
createProcessEnv
|
||||
:: FilePath
|
||||
-> String
|
||||
-> [String]
|
||||
-> IO ProcessHandle
|
||||
createProcessEnv fp proc args = do
|
||||
mPath <- System.Environment.lookupEnv "PATH"
|
||||
|
||||
(_, _, _, ph) <-
|
||||
System.Process.createProcess (System.Process.proc proc args)
|
||||
{ cwd = Just fp
|
||||
, env = Just $ mockedEnv mPath fp
|
||||
}
|
||||
pure ph
|
||||
|
||||
mockedEnv
|
||||
:: Maybe String
|
||||
-> FilePath
|
||||
-> [(String, FilePath)]
|
||||
mockedEnv mEnvPath fp =
|
||||
[ ("NIX_STORE_DIR" , fp </> "store")
|
||||
, ("NIX_LOCALSTATE_DIR", fp </> "var")
|
||||
, ("NIX_LOG_DIR" , fp </> "var" </> "log")
|
||||
, ("NIX_STATE_DIR" , fp </> "var" </> "nix")
|
||||
, ("NIX_CONF_DIR" , fp </> "etc")
|
||||
, ("HOME" , fp </> "home")
|
||||
-- , ("NIX_REMOTE", "daemon")
|
||||
] <> foldMap (\x -> [("PATH", x)]) mEnvPath
|
||||
|
||||
waitSocket
|
||||
:: FilePath
|
||||
-> Int
|
||||
-> IO ()
|
||||
waitSocket _ 0 = fail "No socket"
|
||||
waitSocket fp x = do
|
||||
ex <- System.Directory.doesFileExist fp
|
||||
unless ex $ do
|
||||
Control.Concurrent.threadDelay 100000
|
||||
waitSocket fp (x - 1)
|
||||
|
||||
writeConf :: FilePath -> IO ()
|
||||
writeConf fp =
|
||||
writeFile fp $ unlines
|
||||
[ "build-users-group = "
|
||||
, "trusted-users = root"
|
||||
, "allowed-users = *"
|
||||
, "fsync-metadata = false"
|
||||
]
|
||||
|
||||
{-
|
||||
- we run in user namespace as root but groups are failed
|
||||
- => build-users-group has to be empty but we still
|
||||
- get an error (maybe older nix-daemon)
|
||||
-
|
||||
uid=0(root) gid=65534(nobody) groups=65534(nobody)
|
||||
|
||||
drwxr-xr-x 3 0 65534 60 Nov 29 05:53 store
|
||||
|
||||
accepted connection from pid 22959, user root (trusted)
|
||||
error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e5616122/store': Invalid argument
|
||||
-}
|
||||
|
||||
startDaemon
|
||||
:: FilePath
|
||||
-> IO (ProcessHandle, MonadStore a -> Run IO a)
|
||||
startDaemon fp = do
|
||||
writeConf (fp </> "etc" </> "nix.conf")
|
||||
procHandle <- createProcessEnv fp "nix-daemon" []
|
||||
waitSocket sockFp 30
|
||||
pure ( procHandle
|
||||
, runStoreOpts
|
||||
sockFp
|
||||
(StoreDir
|
||||
$ Data.ByteString.Char8.pack
|
||||
$ fp </> "store"
|
||||
)
|
||||
)
|
||||
where
|
||||
sockFp = fp </> "var/nix/daemon-socket/socket"
|
||||
|
||||
enterNamespaces :: IO ()
|
||||
enterNamespaces = do
|
||||
uid <- System.Posix.User.getEffectiveUserID
|
||||
gid <- System.Posix.User.getEffectiveGroupID
|
||||
|
||||
System.Linux.Namespaces.unshare
|
||||
[User, Network, Mount]
|
||||
|
||||
-- fmap our (parent) uid to root
|
||||
System.Linux.Namespaces.writeUserMappings
|
||||
Nothing
|
||||
[ UserMapping
|
||||
0 -- inside namespace
|
||||
uid -- outside namespace
|
||||
1 --range
|
||||
]
|
||||
|
||||
-- fmap our (parent) gid to root group
|
||||
System.Linux.Namespaces.writeGroupMappings
|
||||
Nothing
|
||||
[ GroupMapping 0 gid 1 ]
|
||||
True
|
||||
|
||||
withNixDaemon
|
||||
:: ((MonadStore a -> Run IO a) -> IO a)
|
||||
-> IO a
|
||||
withNixDaemon action =
|
||||
System.IO.Temp.withSystemTempDirectory "test-nix-store" $ \path -> do
|
||||
|
||||
mapM_ (System.Directory.createDirectory . snd)
|
||||
(filter
|
||||
((/= "NIX_REMOTE") . fst)
|
||||
$ mockedEnv Nothing path)
|
||||
|
||||
ini <- createProcessEnv path "nix-store" ["--init"]
|
||||
void $ System.Process.waitForProcess ini
|
||||
|
||||
writeFile (path </> "dummy") "Hello World"
|
||||
|
||||
System.Directory.setCurrentDirectory path
|
||||
|
||||
Control.Exception.bracket
|
||||
(startDaemon path)
|
||||
(System.Process.terminateProcess . fst)
|
||||
(action . snd)
|
||||
|
||||
checks
|
||||
:: ( Show a
|
||||
, Show b
|
||||
)
|
||||
=> IO (a, b)
|
||||
-> (a -> Bool)
|
||||
-> IO ()
|
||||
checks action check =
|
||||
action >>= (`Test.Hspec.shouldSatisfy` (check . fst))
|
||||
|
||||
it
|
||||
:: (Show a, Show b, Monad m)
|
||||
=> String
|
||||
-> m c
|
||||
-> (a -> Bool)
|
||||
-> SpecWith (m () -> IO (a, b))
|
||||
it name action check =
|
||||
Test.Hspec.it name $ \run -> run (void $ action) `checks` check
|
||||
|
||||
itRights
|
||||
:: ( Show a
|
||||
, Show b
|
||||
, Show c
|
||||
, Monad m
|
||||
)
|
||||
=> String
|
||||
-> m d
|
||||
-> SpecWith (m () -> IO (Either a b, c))
|
||||
itRights name action = it name action Data.Either.isRight
|
||||
|
||||
itLefts
|
||||
:: ( Show a
|
||||
, Show b
|
||||
, Show c
|
||||
, Monad m
|
||||
)
|
||||
=> String
|
||||
-> m d
|
||||
-> SpecWith (m () -> IO (Either a b, c))
|
||||
itLefts name action = it name action Data.Either.isLeft
|
||||
|
||||
withPath
|
||||
:: (StorePath -> MonadStore a)
|
||||
-> MonadStore a
|
||||
withPath action = do
|
||||
path <-
|
||||
addTextToStore
|
||||
(StoreText
|
||||
(forceRight $ System.Nix.StorePath.mkStorePathName "hnix-store")
|
||||
"test"
|
||||
)
|
||||
mempty
|
||||
RepairMode_DontRepair
|
||||
action path
|
||||
|
||||
-- | dummy path, adds <tmp>/dummy with "Hello World" contents
|
||||
dummy :: MonadStore StorePath
|
||||
dummy = do
|
||||
addToStore
|
||||
(forceRight $ System.Nix.StorePath.mkStorePathName "dummy")
|
||||
(System.Nix.Nar.dumpPath "dummy")
|
||||
FileIngestionMethod_Flat
|
||||
(Some HashAlgo_SHA256)
|
||||
RepairMode_DontRepair
|
||||
|
||||
invalidPath :: StorePath
|
||||
invalidPath =
|
||||
let name = forceRight $ System.Nix.StorePath.mkStorePathName "invalid"
|
||||
in System.Nix.StorePath.unsafeMakeStorePath
|
||||
(System.Nix.StorePath.mkStorePathHashPart
|
||||
@SHA256
|
||||
"invalid")
|
||||
name
|
||||
|
||||
_withBuilder
|
||||
:: MonadRemoteStore m
|
||||
=> (StorePath -> m a)
|
||||
-> m a
|
||||
_withBuilder action = do
|
||||
path <-
|
||||
addTextToStore
|
||||
(StoreText (forceRight $ System.Nix.StorePath.mkStorePathName "builder") builderSh)
|
||||
mempty
|
||||
RepairMode_DontRepair
|
||||
action path
|
||||
|
||||
builderSh :: Text
|
||||
builderSh = "declare -xpexport > $out"
|
||||
|
||||
spec :: Spec
|
||||
spec = around withNixDaemon $
|
||||
|
||||
describe "store" $ do
|
||||
|
||||
context "syncWithGC" $
|
||||
itRights "syncs with garbage collector" syncWithGC
|
||||
|
||||
context "verifyStore" $ do
|
||||
itRights "check=False repair=False" $
|
||||
verifyStore
|
||||
CheckMode_DontCheck
|
||||
RepairMode_DontRepair
|
||||
`shouldReturn` False
|
||||
|
||||
itRights "check=True repair=False" $
|
||||
verifyStore
|
||||
CheckMode_DoCheck
|
||||
RepairMode_DontRepair
|
||||
`shouldReturn` False
|
||||
|
||||
--privileged
|
||||
itRights "check=True repair=True" $
|
||||
verifyStore
|
||||
CheckMode_DoCheck
|
||||
RepairMode_DoRepair
|
||||
`shouldReturn` False
|
||||
|
||||
context "addTextToStore" $
|
||||
itRights "adds text to store" $ withPath pure
|
||||
|
||||
context "isValidPath" $ do
|
||||
itRights "validates path" $ withPath $ \path -> do
|
||||
liftIO $ print path
|
||||
isValidPath path `shouldReturn` True
|
||||
itLefts "fails on invalid path"
|
||||
$ System.Nix.Store.Remote.MonadStore.mapStoreConfig
|
||||
(\sc -> sc { storeConfig_dir = StoreDir "/asdf" })
|
||||
$ isValidPath invalidPath
|
||||
|
||||
context "queryAllValidPaths" $ do
|
||||
itRights "empty query" queryAllValidPaths
|
||||
itRights "non-empty query" $ withPath $ \path ->
|
||||
queryAllValidPaths `shouldReturn` Data.HashSet.fromList [path]
|
||||
|
||||
context "queryPathInfo" $
|
||||
itRights "queries path info" $ withPath $ \path -> do
|
||||
meta <- queryPathInfo path
|
||||
(metadataReferences <$> meta) `shouldBe` (Just mempty)
|
||||
|
||||
context "ensurePath" $
|
||||
itRights "simple ensure" $ withPath ensurePath
|
||||
|
||||
context "addTempRoot" $
|
||||
itRights "simple addition" $ withPath addTempRoot
|
||||
|
||||
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
|
||||
buildPaths (toDerivedPathSet path) BuildMode_Normal
|
||||
|
||||
itRights "build Check" $ withPath $ \path -> do
|
||||
buildPaths (toDerivedPathSet path) BuildMode_Check
|
||||
|
||||
itLefts "build Repair" $ withPath $ \path -> do
|
||||
buildPaths (toDerivedPathSet path) BuildMode_Repair
|
||||
|
||||
context "roots" $ context "findRoots" $ do
|
||||
itRights "empty roots" (findRoots `shouldReturn` mempty)
|
||||
|
||||
itRights "path added as a temp root" $ withPath $ \_ -> do
|
||||
roots <- findRoots
|
||||
roots `shouldSatisfy` ((== 1) . Data.Map.size)
|
||||
|
||||
context "optimiseStore" $ itRights "optimises" optimiseStore
|
||||
|
||||
context "queryMissing" $
|
||||
itRights "queries" $ withPath $ \path -> do
|
||||
queryMissing (toDerivedPathSet path)
|
||||
`shouldReturn`
|
||||
Missing
|
||||
{ missingWillBuild = mempty
|
||||
, missingWillSubstitute = mempty
|
||||
, missingUnknownPaths = mempty
|
||||
, missingDownloadSize = 0
|
||||
, missingNarSize = 0
|
||||
}
|
||||
|
||||
context "addToStore" $
|
||||
itRights "adds file to store" $ do
|
||||
fp <-
|
||||
liftIO
|
||||
$ System.IO.Temp.writeSystemTempFile
|
||||
"addition"
|
||||
"yolo"
|
||||
|
||||
addToStore
|
||||
(forceRight $ System.Nix.StorePath.mkStorePathName "tmp-addition")
|
||||
(System.Nix.Nar.dumpPath fp)
|
||||
FileIngestionMethod_Flat
|
||||
(Some HashAlgo_SHA256)
|
||||
RepairMode_DontRepair
|
||||
|
||||
context "with dummy" $ do
|
||||
itRights "adds dummy" dummy
|
||||
|
||||
itRights "valid dummy" $ do
|
||||
path <- dummy
|
||||
isValidPath path `shouldReturn` True
|
||||
|
||||
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/" ]
|
||||
tempRootList <-
|
||||
liftIO
|
||||
$ System.Directory.listDirectory
|
||||
tempRootsDir
|
||||
liftIO $ forM_ tempRootList $ \entry -> do
|
||||
System.Directory.removeFile
|
||||
$ mconcat [ tempRootsDir, "/", entry ]
|
||||
|
||||
GCResult{..} <-
|
||||
collectGarbage
|
||||
GCOptions
|
||||
{ gcOptionsOperation = GCAction_DeleteSpecific
|
||||
, gcOptionsIgnoreLiveness = False
|
||||
, gcOptionsPathsToDelete = Data.HashSet.fromList [path]
|
||||
, gcOptionsMaxFreed = maxBound
|
||||
}
|
||||
gcResultDeletedPaths `shouldBe` Data.HashSet.fromList [path]
|
||||
gcResultBytesFreed `shouldBe` 4
|
@ -1 +0,0 @@
|
||||
{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Spec #-}
|
136
hnix-store-remote/tests/EnumSpec.hs
Normal file
136
hnix-store-remote/tests/EnumSpec.hs
Normal file
@ -0,0 +1,136 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module EnumSpec (spec) where
|
||||
|
||||
import Test.Hspec (SpecWith, Spec, describe, it, shouldBe)
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Word (Word64)
|
||||
import System.Nix.Build (BuildMode(..), BuildStatus(..))
|
||||
import System.Nix.Store.Remote.Serializer
|
||||
( activity
|
||||
, activityResult
|
||||
, enum
|
||||
, int
|
||||
, loggerOpCode
|
||||
, runP
|
||||
, LoggerSError
|
||||
, NixSerializer
|
||||
, SError
|
||||
)
|
||||
import System.Nix.Store.Remote.Types
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
let
|
||||
itE
|
||||
:: ( Enum a
|
||||
, Show a
|
||||
)
|
||||
=> String
|
||||
-> a
|
||||
-> Word64
|
||||
-> SpecWith ()
|
||||
itE name constr value =
|
||||
it name
|
||||
$ ((runP enum () constr) :: Either SError ByteString)
|
||||
`shouldBe`
|
||||
(runP (int @Word64) () value)
|
||||
|
||||
itE'
|
||||
:: Show a
|
||||
=> NixSerializer () LoggerSError a
|
||||
-> String
|
||||
-> a
|
||||
-> Word64
|
||||
-> SpecWith ()
|
||||
itE' s name constr value =
|
||||
it name
|
||||
$ ((runP s () constr) :: Either LoggerSError ByteString)
|
||||
`shouldBe`
|
||||
(runP (int @Word64) () (value))
|
||||
|
||||
describe "Enums" $ do
|
||||
describe "BuildMode enum order matches Nix" $ do
|
||||
itE "Normal" BuildMode_Normal 0
|
||||
itE "Repair" BuildMode_Repair 1
|
||||
itE "Check" BuildMode_Check 2
|
||||
|
||||
describe "BuildStatus enum order matches Nix" $ do
|
||||
itE "Built" BuildStatus_Built 0
|
||||
itE "Substituted" BuildStatus_Substituted 1
|
||||
itE "AlreadyValid" BuildStatus_AlreadyValid 2
|
||||
itE "PermanentFailure" BuildStatus_PermanentFailure 3
|
||||
itE "InputRejected" BuildStatus_InputRejected 4
|
||||
itE "OutputRejected" BuildStatus_OutputRejected 5
|
||||
itE "TransientFailure" BuildStatus_TransientFailure 6
|
||||
itE "CachedFailure" BuildStatus_CachedFailure 7
|
||||
itE "TimedOut" BuildStatus_TimedOut 8
|
||||
itE "MiscFailure" BuildStatus_MiscFailure 9
|
||||
itE "DependencyFailed" BuildStatus_DependencyFailed 10
|
||||
itE "LogLimitExceeded" BuildStatus_LogLimitExceeded 11
|
||||
itE "NotDeterministic" BuildStatus_NotDeterministic 12
|
||||
itE "ResolvesToAlreadyValid" BuildStatus_ResolvesToAlreadyValid 13
|
||||
itE "NoSubstituters" BuildStatus_NoSubstituters 14
|
||||
|
||||
describe "GCAction enum order matches Nix" $ do
|
||||
itE "ReturnLive" GCAction_ReturnLive 0
|
||||
itE "ReturnDead" GCAction_ReturnDead 1
|
||||
itE "DeleteDead" GCAction_DeleteDead 2
|
||||
itE "DeleteSpecific" GCAction_DeleteSpecific 3
|
||||
|
||||
describe "Logger" $ do
|
||||
let itA = itE' activity
|
||||
describe "Activity enum order matches Nix" $ do
|
||||
itA "CopyPath" Activity_CopyPath 100
|
||||
itA "FileTransfer" Activity_FileTransfer 101
|
||||
itA "Realise" Activity_Realise 102
|
||||
itA "CopyPaths" Activity_CopyPaths 103
|
||||
itA "Builds" Activity_Builds 104
|
||||
itA "Build" Activity_Build 105
|
||||
itA "OptimiseStore" Activity_OptimiseStore 106
|
||||
itA "VerifyPaths" Activity_VerifyPaths 107
|
||||
itA "Substitute" Activity_Substitute 108
|
||||
itA "QueryPathInfo" Activity_QueryPathInfo 109
|
||||
itA "PostBuildHook" Activity_PostBuildHook 110
|
||||
itA "BuildWaiting" Activity_BuildWaiting 111
|
||||
|
||||
let itR = itE' activityResult
|
||||
describe "ActivityResult enum order matches Nix" $ do
|
||||
itR "FileLinked" ActivityResult_FileLinked 100
|
||||
itR "BuildLogLine" ActivityResult_BuildLogLine 101
|
||||
itR "UnstrustedPath" ActivityResult_UnstrustedPath 102
|
||||
itR "CorruptedPath" ActivityResult_CorruptedPath 103
|
||||
itR "SetPhase" ActivityResult_SetPhase 104
|
||||
itR "Progress" ActivityResult_Progress 105
|
||||
itR "SetExpected" ActivityResult_SetExpected 106
|
||||
itR "PostBuildLogLine" ActivityResult_PostBuildLogLine 107
|
||||
|
||||
|
||||
let itL = itE' loggerOpCode
|
||||
describe "LoggerOpCode matches Nix" $ do
|
||||
itL "Next" LoggerOpCode_Next 0x6f6c6d67
|
||||
itL "Read" LoggerOpCode_Read 0x64617461
|
||||
itL "Write" LoggerOpCode_Write 0x64617416
|
||||
itL "Last" LoggerOpCode_Last 0x616c7473
|
||||
itL "Error" LoggerOpCode_Error 0x63787470
|
||||
itL "StartActivity" LoggerOpCode_StartActivity 0x53545254
|
||||
itL "StopActivity" LoggerOpCode_StopActivity 0x53544f50
|
||||
itL "Result" LoggerOpCode_Result 0x52534c54
|
||||
|
||||
describe "Verbosity enum order matches Nix" $ do
|
||||
itE "Error" Verbosity_Error 0
|
||||
itE "Warn" Verbosity_Warn 1
|
||||
itE "Notice" Verbosity_Notice 2
|
||||
itE "Info" Verbosity_Info 3
|
||||
itE "Talkative" Verbosity_Talkative 4
|
||||
itE "Chatty" Verbosity_Chatty 5
|
||||
itE "Debug" Verbosity_Debug 6
|
||||
itE "Vomit" Verbosity_Vomit 7
|
||||
|
||||
describe "WorkerOp enum order matches Nix" $ do
|
||||
itE "IsValidPath" WorkerOp_IsValidPath 1
|
||||
itE "BuildPathsWithResults" WorkerOp_BuildPathsWithResults 46
|
||||
|
||||
|
||||
|
@ -3,27 +3,22 @@
|
||||
module NixSerializerSpec (spec) where
|
||||
|
||||
import Crypto.Hash (MD5, SHA1, SHA256, SHA512)
|
||||
import Data.Dependent.Sum (DSum((:=>)))
|
||||
import Data.Fixed (Uni)
|
||||
import Data.Time (NominalDiffTime)
|
||||
import Data.Some (Some(Some))
|
||||
import Data.Time (UTCTime)
|
||||
import Test.Hspec (Expectation, Spec, describe, parallel, shouldBe)
|
||||
import Test.Hspec.QuickCheck (prop)
|
||||
import Test.QuickCheck (Gen, arbitrary, forAll, suchThat)
|
||||
import Test.QuickCheck.Instances ()
|
||||
|
||||
import qualified Data.Time.Clock.POSIX
|
||||
import qualified Data.Serializer
|
||||
import qualified System.Nix.Build
|
||||
import qualified System.Nix.Hash
|
||||
|
||||
import System.Nix.Arbitrary ()
|
||||
import System.Nix.Build (BuildResult)
|
||||
import System.Nix.Derivation (Derivation(inputDrvs))
|
||||
import System.Nix.Build (BuildResult(..))
|
||||
import System.Nix.StorePath (StoreDir)
|
||||
import System.Nix.StorePath.Metadata (Metadata(..))
|
||||
import System.Nix.Store.Remote.Arbitrary ()
|
||||
import System.Nix.Store.Remote.Serializer
|
||||
import System.Nix.Store.Remote.Types (ErrorInfo(..), Logger(..), ProtoVersion(..), Trace(..))
|
||||
import System.Nix.Store.Remote.Types.Logger (Logger(..))
|
||||
import System.Nix.Store.Remote.Types.ProtoVersion (HasProtoVersion(..), ProtoVersion(..))
|
||||
import System.Nix.Store.Remote.Types.StoreConfig (TestStoreConfig(..))
|
||||
import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))
|
||||
|
||||
-- | Test for roundtrip using @NixSerializer@
|
||||
roundtripSReader
|
||||
@ -60,22 +55,8 @@ spec = parallel $ do
|
||||
prop "Bool" $ roundtripS bool
|
||||
prop "ByteString" $ roundtripS byteString
|
||||
prop "Text" $ roundtripS text
|
||||
prop "Maybe Text"
|
||||
$ forAll (arbitrary `suchThat` (/= Just ""))
|
||||
$ roundtripS maybeText
|
||||
prop "UTCTime" $ do
|
||||
let
|
||||
-- scale to seconds and back
|
||||
toSeconds :: Int -> NominalDiffTime
|
||||
toSeconds n = realToFrac (toEnum n :: Uni)
|
||||
fromSeconds :: NominalDiffTime -> Int
|
||||
fromSeconds = (fromEnum :: Uni -> Int) . realToFrac
|
||||
|
||||
roundtripS @Int @() $
|
||||
Data.Serializer.mapIsoSerializer
|
||||
(fromSeconds . Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds)
|
||||
(Data.Time.Clock.POSIX.posixSecondsToUTCTime . toSeconds)
|
||||
time
|
||||
prop "Maybe Text" $ roundtripS maybeText
|
||||
prop "UTCTime" $ roundtripS @UTCTime @() time
|
||||
|
||||
describe "Combinators" $ do
|
||||
prop "list" $ roundtripS @[Int] @() (list int)
|
||||
@ -84,14 +65,33 @@ spec = parallel $ do
|
||||
prop "mapS" $ roundtripS (mapS (int @Int) byteString)
|
||||
|
||||
describe "Complex" $ do
|
||||
prop "BuildResult"
|
||||
$ forAll (arbitrary `suchThat` ((/= Just "") . System.Nix.Build.errorMessage))
|
||||
$ \br ->
|
||||
roundtripS @BuildResult buildResult
|
||||
-- fix time to 0 as we test UTCTime above
|
||||
$ br { System.Nix.Build.startTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
|
||||
, System.Nix.Build.stopTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
|
||||
}
|
||||
prop "DSum HashAlgo Digest" $ roundtripS namedDigest
|
||||
|
||||
describe "BuildResult" $ do
|
||||
prop "< 1.28"
|
||||
$ \sd -> forAll (arbitrary `suchThat` ((< 28) . protoVersion_minor))
|
||||
$ \pv ->
|
||||
roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv)
|
||||
. (\x -> x { buildResultBuiltOutputs = Nothing })
|
||||
. (\x -> x { buildResultTimesBuilt = Nothing
|
||||
, buildResultIsNonDeterministic = Nothing
|
||||
, buildResultStartTime = Nothing
|
||||
, buildResultStopTime = Nothing
|
||||
}
|
||||
)
|
||||
prop "= 1.28"
|
||||
$ \sd ->
|
||||
roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd (ProtoVersion 1 28))
|
||||
. (\x -> x { buildResultTimesBuilt = Nothing
|
||||
, buildResultIsNonDeterministic = Nothing
|
||||
, buildResultStartTime = Nothing
|
||||
, buildResultStopTime = Nothing
|
||||
}
|
||||
)
|
||||
prop "> 1.28"
|
||||
$ \sd -> forAll (arbitrary `suchThat` ((> 28) . protoVersion_minor))
|
||||
$ \pv ->
|
||||
roundtripSReader @TestStoreConfig buildResult (TestStoreConfig sd pv)
|
||||
|
||||
prop "StorePath" $
|
||||
roundtripSReader @StoreDir storePath
|
||||
@ -102,17 +102,8 @@ spec = parallel $ do
|
||||
prop "StorePathName" $
|
||||
roundtripS storePathName
|
||||
|
||||
let narHashIsSHA256 Metadata{..} =
|
||||
case narHash of
|
||||
(System.Nix.Hash.HashAlgo_SHA256 :=> _) -> True
|
||||
_ -> False
|
||||
|
||||
prop "Metadata (StorePath)"
|
||||
$ \sd -> forAll (arbitrary `suchThat` (\m -> narHashIsSHA256 m && narBytes m /= Just 0))
|
||||
$ roundtripSReader @StoreDir pathMetadata sd
|
||||
. (\m -> m
|
||||
{ registrationTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
|
||||
})
|
||||
prop "Metadata (StorePath)" $
|
||||
roundtripSReader @StoreDir pathMetadata
|
||||
|
||||
prop "Some HashAlgo" $
|
||||
roundtripS someHashAlgo
|
||||
@ -134,19 +125,9 @@ spec = parallel $ do
|
||||
prop "Maybe Activity" $ roundtripS maybeActivity
|
||||
prop "ActivityResult" $ roundtripS activityResult
|
||||
prop "Field" $ roundtripS field
|
||||
prop "Trace"
|
||||
$ forAll (arbitrary `suchThat` ((/= Just 0) . tracePosition))
|
||||
$ roundtripS trace
|
||||
prop "Trace" $ roundtripS trace
|
||||
prop "BasicError" $ roundtripS basicError
|
||||
prop "ErrorInfo"
|
||||
$ forAll (arbitrary
|
||||
`suchThat`
|
||||
(\ErrorInfo{..}
|
||||
-> errorInfoPosition /= Just 0
|
||||
&& all ((/= Just 0) . tracePosition) errorInfoTraces
|
||||
)
|
||||
)
|
||||
$ roundtripS errorInfo
|
||||
prop "ErrorInfo" $ roundtripS errorInfo
|
||||
prop "LoggerOpCode" $ roundtripS loggerOpCode
|
||||
prop "Verbosity" $ roundtripS verbosity
|
||||
prop "Logger"
|
||||
@ -154,11 +135,35 @@ spec = parallel $ do
|
||||
$ \pv ->
|
||||
forAll (arbitrary `suchThat` errorInfoIf (protoVersion_minor pv >= 26))
|
||||
$ roundtripSReader logger pv
|
||||
where
|
||||
errorInfoIf True (Logger_Error (Right x)) = noJust0s x
|
||||
errorInfoIf False (Logger_Error (Left _)) = True
|
||||
errorInfoIf _ (Logger_Error _) = False
|
||||
errorInfoIf _ _ = True
|
||||
noJust0s ErrorInfo{..} =
|
||||
errorInfoPosition /= Just 0
|
||||
&& all ((/= Just 0) . tracePosition) errorInfoTraces
|
||||
|
||||
describe "Handshake" $ do
|
||||
prop "WorkerMagic" $ roundtripS workerMagic
|
||||
prop "TrustedFlag" $ roundtripS trustedFlag
|
||||
|
||||
describe "Worker protocol" $ do
|
||||
prop "WorkerOp" $ roundtripS workerOp
|
||||
prop "StoreText" $ roundtripS storeText
|
||||
|
||||
prop "StoreRequest"
|
||||
$ \testStoreConfig ->
|
||||
forAll (arbitrary `suchThat` (restrictProtoVersion (hasProtoVersion testStoreConfig)))
|
||||
$ roundtripSReader @TestStoreConfig storeRequest testStoreConfig
|
||||
|
||||
describe "StoreReply" $ do
|
||||
prop "()" $ roundtripS opSuccess
|
||||
prop "GCResult" $ roundtripSReader @StoreDir gcResult
|
||||
prop "GCRoot" $ roundtripS gcRoot
|
||||
prop "Missing" $ roundtripSReader @StoreDir missing
|
||||
prop "Maybe (Metadata StorePath)" $ roundtripSReader @StoreDir maybePathMetadata
|
||||
|
||||
restrictProtoVersion :: ProtoVersion -> Some StoreRequest -> Bool
|
||||
restrictProtoVersion v (Some (BuildPaths _ _)) | v < ProtoVersion 1 30 = False
|
||||
restrictProtoVersion _ (Some (BuildDerivation _ drv _)) = inputDrvs drv == mempty
|
||||
restrictProtoVersion v (Some (QueryMissing _)) | v < ProtoVersion 1 30 = False
|
||||
restrictProtoVersion _ _ = True
|
||||
|
||||
errorInfoIf :: Bool -> Logger -> Bool
|
||||
errorInfoIf True (Logger_Error (Right _)) = True
|
||||
errorInfoIf False (Logger_Error (Left _)) = True
|
||||
errorInfoIf _ (Logger_Error _) = False
|
||||
errorInfoIf _ _ = True
|
||||
|
@ -1,208 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module SerializeSpec (spec) where
|
||||
|
||||
import Data.Fixed (Uni)
|
||||
import Data.Serialize (Serialize(..))
|
||||
import Data.Serialize.Get (Get, runGet)
|
||||
import Data.Serialize.Put (Putter, runPut)
|
||||
import Data.Text (Text)
|
||||
import Data.Time (NominalDiffTime)
|
||||
import Test.Hspec (Expectation, Spec, describe, it, parallel, shouldBe)
|
||||
import Test.Hspec.QuickCheck (prop)
|
||||
import Test.Hspec.Nix (roundtrips)
|
||||
import Test.QuickCheck (arbitrary, forAll, suchThat)
|
||||
import Test.QuickCheck.Instances ()
|
||||
|
||||
import qualified Data.Either
|
||||
import qualified Data.HashSet
|
||||
import qualified Data.Time.Clock.POSIX
|
||||
import qualified System.Nix.Build
|
||||
|
||||
import System.Nix.Arbitrary ()
|
||||
import System.Nix.Build (BuildMode(..), BuildStatus(..))
|
||||
import System.Nix.Derivation (Derivation(inputDrvs))
|
||||
import System.Nix.Store.Remote.Arbitrary ()
|
||||
import System.Nix.Store.Remote.Serialize (getDerivation, putDerivation)
|
||||
import System.Nix.Store.Remote.Serialize.Prim
|
||||
import System.Nix.Store.Remote.Types
|
||||
|
||||
-- | Test for roundtrip using @Putter@ and @Get@ functions
|
||||
roundtrips2
|
||||
:: ( Eq a
|
||||
, Show a
|
||||
)
|
||||
=> Putter a
|
||||
-> Get a
|
||||
-> a
|
||||
-> Expectation
|
||||
roundtrips2 putter getter =
|
||||
roundtrips
|
||||
(runPut . putter)
|
||||
(runGet getter)
|
||||
|
||||
-- | Test for roundtrip using @Serialize@ instance
|
||||
roundtripS
|
||||
:: ( Eq a
|
||||
, Serialize a
|
||||
, Show a
|
||||
)
|
||||
=> a
|
||||
-> Expectation
|
||||
roundtripS =
|
||||
roundtrips
|
||||
(runPut . put)
|
||||
(runGet get)
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "Prim" $ do
|
||||
prop "Int" $ roundtrips2 putInt (getInt @Int)
|
||||
prop "Bool" $ roundtrips2 putBool getBool
|
||||
prop "ByteString" $ roundtrips2 putByteString getByteString
|
||||
|
||||
prop "UTCTime" $ do
|
||||
let
|
||||
-- scale to seconds and back
|
||||
toSeconds :: Int -> NominalDiffTime
|
||||
toSeconds n = realToFrac (toEnum n :: Uni)
|
||||
fromSeconds :: NominalDiffTime -> Int
|
||||
fromSeconds = (fromEnum :: Uni -> Int) . realToFrac
|
||||
|
||||
roundtrips2
|
||||
(putTime . Data.Time.Clock.POSIX.posixSecondsToUTCTime . toSeconds)
|
||||
(fromSeconds . Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds <$> getTime)
|
||||
|
||||
describe "Combinators" $ do
|
||||
prop "Many" $ roundtrips2 (putMany putInt) (getMany (getInt @Int))
|
||||
prop "[ByteString]" $ roundtrips2 putByteStrings getByteStrings
|
||||
prop "Text" $ roundtrips2 putText getText
|
||||
prop "[Text]" $ roundtrips2 putTexts getTexts
|
||||
|
||||
prop "StorePath" $ \sd ->
|
||||
roundtrips2
|
||||
(putPath sd)
|
||||
(Data.Either.fromRight undefined <$> getPath sd)
|
||||
|
||||
prop "HashSet StorePath" $ \sd ->
|
||||
roundtrips2
|
||||
(putPaths sd)
|
||||
(Data.HashSet.map (Data.Either.fromRight undefined) <$> getPaths sd)
|
||||
|
||||
describe "Serialize instances" $ do
|
||||
prop "Text" $ roundtripS @Text
|
||||
prop "BuildMode" $ roundtripS @BuildMode
|
||||
prop "BuildStatus" $ roundtripS @BuildStatus
|
||||
it "BuildResult" $
|
||||
forAll (arbitrary `suchThat` ((/= Just "") . System.Nix.Build.errorMessage))
|
||||
$ \br ->
|
||||
roundtripS
|
||||
-- fix time to 0 as we test UTCTime above
|
||||
$ br { System.Nix.Build.startTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
|
||||
, System.Nix.Build.stopTime = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
|
||||
}
|
||||
|
||||
prop "ProtoVersion" $ roundtripS @ProtoVersion
|
||||
|
||||
prop "Derivation StorePath Text" $ \sd ->
|
||||
roundtrips2
|
||||
(putDerivation sd)
|
||||
(getDerivation sd)
|
||||
-- inputDrvs is not used in remote protocol serialization
|
||||
. (\drv -> drv { inputDrvs = mempty })
|
||||
|
||||
describe "Logger" $ do
|
||||
prop "Activity" $ roundtripS @Activity
|
||||
prop "ActivityID" $ roundtripS @ActivityID
|
||||
prop "Activity" $ roundtripS @Activity
|
||||
prop "Field" $ roundtripS @Field
|
||||
prop "Trace"
|
||||
$ forAll (arbitrary `suchThat` ((/= Just 0) . tracePosition))
|
||||
$ roundtripS @Trace
|
||||
prop "BasicError" $ roundtripS @BasicError
|
||||
prop "ErrorInfo"
|
||||
$ forAll (arbitrary
|
||||
`suchThat`
|
||||
(\ErrorInfo{..}
|
||||
-> errorInfoPosition /= Just 0
|
||||
&& all ((/= Just 0) . tracePosition) errorInfoTraces
|
||||
)
|
||||
)
|
||||
$ roundtripS @ErrorInfo
|
||||
prop "LoggerOpCode" $ roundtripS @LoggerOpCode
|
||||
prop "Verbosity" $ roundtripS @Verbosity
|
||||
|
||||
describe "Enums" $ do
|
||||
let it' name constr value = it name $ runPut (put constr) `shouldBe` runPut (putInt @Int value)
|
||||
describe "BuildMode enum order matches Nix" $ do
|
||||
it' "Normal" BuildMode_Normal 0
|
||||
it' "Repair" BuildMode_Repair 1
|
||||
it' "Check" BuildMode_Check 2
|
||||
|
||||
describe "BuildStatus enum order matches Nix" $ do
|
||||
it' "Built" BuildStatus_Built 0
|
||||
it' "Substituted" BuildStatus_Substituted 1
|
||||
it' "AlreadyValid" BuildStatus_AlreadyValid 2
|
||||
it' "PermanentFailure" BuildStatus_PermanentFailure 3
|
||||
it' "InputRejected" BuildStatus_InputRejected 4
|
||||
it' "OutputRejected" BuildStatus_OutputRejected 5
|
||||
it' "TransientFailure" BuildStatus_TransientFailure 6
|
||||
it' "CachedFailure" BuildStatus_CachedFailure 7
|
||||
it' "TimedOut" BuildStatus_TimedOut 8
|
||||
it' "MiscFailure" BuildStatus_MiscFailure 9
|
||||
it' "DependencyFailed" BuildStatus_DependencyFailed 10
|
||||
it' "LogLimitExceeded" BuildStatus_LogLimitExceeded 11
|
||||
it' "NotDeterministic" BuildStatus_NotDeterministic 12
|
||||
it' "ResolvesToAlreadyValid" BuildStatus_ResolvesToAlreadyValid 13
|
||||
it' "NoSubstituters" BuildStatus_NoSubstituters 14
|
||||
|
||||
describe "GCAction enum order matches Nix" $ do
|
||||
it' "ReturnLive" GCAction_ReturnLive 0
|
||||
it' "ReturnDead" GCAction_ReturnDead 1
|
||||
it' "DeleteDead" GCAction_DeleteDead 2
|
||||
it' "DeleteSpecific" GCAction_DeleteSpecific 3
|
||||
|
||||
describe "Logger" $ do
|
||||
describe "Activity enum order matches Nix" $ do
|
||||
it' "CopyPath" Activity_CopyPath 100
|
||||
it' "FileTransfer" Activity_FileTransfer 101
|
||||
it' "Realise" Activity_Realise 102
|
||||
it' "CopyPaths" Activity_CopyPaths 103
|
||||
it' "Builds" Activity_Builds 104
|
||||
it' "Build" Activity_Build 105
|
||||
it' "OptimiseStore" Activity_OptimiseStore 106
|
||||
it' "VerifyPaths" Activity_VerifyPaths 107
|
||||
it' "Substitute" Activity_Substitute 108
|
||||
it' "QueryPathInfo" Activity_QueryPathInfo 109
|
||||
it' "PostBuildHook" Activity_PostBuildHook 110
|
||||
it' "BuildWaiting" Activity_BuildWaiting 111
|
||||
|
||||
describe "ActivityResult enum order matches Nix" $ do
|
||||
it' "FileLinked" ActivityResult_FileLinked 100
|
||||
it' "BuildLogLine" ActivityResult_BuildLogLine 101
|
||||
it' "UnstrustedPath" ActivityResult_UnstrustedPath 102
|
||||
it' "CorruptedPath" ActivityResult_CorruptedPath 103
|
||||
it' "SetPhase" ActivityResult_SetPhase 104
|
||||
it' "Progress" ActivityResult_Progress 105
|
||||
it' "SetExpected" ActivityResult_SetExpected 106
|
||||
it' "PostBuildLogLine" ActivityResult_PostBuildLogLine 107
|
||||
|
||||
describe "LoggerOpCode matches Nix" $ do
|
||||
it' "Next" LoggerOpCode_Next 0x6f6c6d67
|
||||
it' "Read" LoggerOpCode_Read 0x64617461
|
||||
it' "Write" LoggerOpCode_Write 0x64617416
|
||||
it' "Last" LoggerOpCode_Last 0x616c7473
|
||||
it' "Error" LoggerOpCode_Error 0x63787470
|
||||
it' "StartActivity" LoggerOpCode_StartActivity 0x53545254
|
||||
it' "StopActivity" LoggerOpCode_StopActivity 0x53544f50
|
||||
it' "Result" LoggerOpCode_Result 0x52534c54
|
||||
|
||||
describe "Verbosity enum order matches Nix" $ do
|
||||
it' "Error" Verbosity_Error 0
|
||||
it' "Warn" Verbosity_Warn 1
|
||||
it' "Notice" Verbosity_Notice 2
|
||||
it' "Info" Verbosity_Info 3
|
||||
it' "Talkative" Verbosity_Talkative 4
|
||||
it' "Chatty" Verbosity_Chatty 5
|
||||
it' "Debug" Verbosity_Debug 6
|
||||
it' "Vomit" Verbosity_Vomit 7
|
@ -35,29 +35,40 @@ common commons
|
||||
library
|
||||
import: commons
|
||||
exposed-modules:
|
||||
System.Nix.Arbitrary
|
||||
Data.ByteString.Arbitrary
|
||||
, Data.HashSet.Arbitrary
|
||||
, Data.Text.Arbitrary
|
||||
, Data.Vector.Arbitrary
|
||||
, System.Nix.Arbitrary
|
||||
, System.Nix.Arbitrary.Base
|
||||
, System.Nix.Arbitrary.Build
|
||||
, System.Nix.Arbitrary.ContentAddress
|
||||
, System.Nix.Arbitrary.Derivation
|
||||
, System.Nix.Arbitrary.DerivedPath
|
||||
, System.Nix.Arbitrary.Hash
|
||||
, System.Nix.Arbitrary.OutputName
|
||||
, System.Nix.Arbitrary.Realisation
|
||||
, System.Nix.Arbitrary.Signature
|
||||
, System.Nix.Arbitrary.Store.Types
|
||||
, System.Nix.Arbitrary.StorePath
|
||||
, System.Nix.Arbitrary.StorePath.Metadata
|
||||
, System.Nix.Arbitrary.UTCTime
|
||||
, Test.Hspec.Nix
|
||||
build-depends:
|
||||
base >=4.12 && <5
|
||||
, hnix-store-core >= 0.8
|
||||
, bytestring
|
||||
, containers
|
||||
, crypton
|
||||
, dependent-sum > 0.7
|
||||
, generic-arbitrary < 1.1
|
||||
, hashable
|
||||
, hspec
|
||||
, QuickCheck
|
||||
, quickcheck-instances
|
||||
, text
|
||||
, time
|
||||
, unordered-containers
|
||||
, vector
|
||||
hs-source-dirs: src
|
||||
|
||||
test-suite props
|
||||
@ -69,6 +80,7 @@ test-suite props
|
||||
ContentAddressSpec
|
||||
DerivationSpec
|
||||
DerivedPathSpec
|
||||
RealisationSpec
|
||||
StorePathSpec
|
||||
SignatureSpec
|
||||
hs-source-dirs:
|
||||
@ -80,8 +92,5 @@ test-suite props
|
||||
, hnix-store-core
|
||||
, hnix-store-tests
|
||||
, attoparsec
|
||||
, containers
|
||||
, data-default-class
|
||||
, QuickCheck
|
||||
, text
|
||||
, hspec
|
||||
|
10
hnix-store-tests/src/Data/ByteString/Arbitrary.hs
Normal file
10
hnix-store-tests/src/Data/ByteString/Arbitrary.hs
Normal file
@ -0,0 +1,10 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module Data.ByteString.Arbitrary () where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Test.QuickCheck (Arbitrary(..))
|
||||
import qualified Data.ByteString.Char8
|
||||
|
||||
instance Arbitrary ByteString where
|
||||
arbitrary = Data.ByteString.Char8.pack <$> arbitrary
|
||||
shrink xs = Data.ByteString.Char8.pack <$> shrink (Data.ByteString.Char8.unpack xs)
|
11
hnix-store-tests/src/Data/HashSet/Arbitrary.hs
Normal file
11
hnix-store-tests/src/Data/HashSet/Arbitrary.hs
Normal file
@ -0,0 +1,11 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Data.HashSet.Arbitrary where
|
||||
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.HashSet (HashSet)
|
||||
import Test.QuickCheck (Arbitrary(..))
|
||||
import qualified Data.HashSet
|
||||
|
||||
instance (Hashable a, Eq a, Arbitrary a) => Arbitrary (HashSet a) where
|
||||
arbitrary = Data.HashSet.fromList <$> arbitrary
|
||||
shrink hashset = Data.HashSet.fromList <$> shrink (Data.HashSet.toList hashset)
|
16
hnix-store-tests/src/Data/Text/Arbitrary.hs
Normal file
16
hnix-store-tests/src/Data/Text/Arbitrary.hs
Normal file
@ -0,0 +1,16 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module Data.Text.Arbitrary () where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Test.QuickCheck (Arbitrary(..), frequency, suchThat)
|
||||
import qualified Data.Text
|
||||
|
||||
instance Arbitrary Text where
|
||||
arbitrary = Data.Text.pack <$> arbitrary
|
||||
shrink xs = Data.Text.pack <$> shrink (Data.Text.unpack xs)
|
||||
|
||||
instance {-# OVERLAPPING #-} Arbitrary (Maybe Text) where
|
||||
arbitrary = frequency
|
||||
[ (1, pure Nothing)
|
||||
, (3, Just <$> arbitrary `suchThat` (/= mempty))
|
||||
]
|
20
hnix-store-tests/src/Data/Vector/Arbitrary.hs
Normal file
20
hnix-store-tests/src/Data/Vector/Arbitrary.hs
Normal file
@ -0,0 +1,20 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
-- Stolen from quickcheck-instances (BSD-3)
|
||||
module Data.Vector.Arbitrary () where
|
||||
|
||||
import Data.Vector (Vector)
|
||||
import Test.QuickCheck (Arbitrary(..), Arbitrary1(..), arbitrary1, shrink1)
|
||||
import qualified Data.Vector
|
||||
|
||||
instance Arbitrary1 Vector where
|
||||
liftArbitrary =
|
||||
fmap Data.Vector.fromList
|
||||
. liftArbitrary
|
||||
liftShrink shr =
|
||||
fmap Data.Vector.fromList
|
||||
. liftShrink shr
|
||||
. Data.Vector.toList
|
||||
|
||||
instance Arbitrary a => Arbitrary (Vector a) where
|
||||
arbitrary = arbitrary1
|
||||
shrink = shrink1
|
@ -1,11 +1,18 @@
|
||||
module System.Nix.Arbitrary where
|
||||
|
||||
import Data.ByteString.Arbitrary ()
|
||||
import Data.HashSet.Arbitrary ()
|
||||
import Data.Text.Arbitrary ()
|
||||
import Data.Vector.Arbitrary ()
|
||||
|
||||
import System.Nix.Arbitrary.Base ()
|
||||
import System.Nix.Arbitrary.Build ()
|
||||
import System.Nix.Arbitrary.ContentAddress ()
|
||||
import System.Nix.Arbitrary.Derivation ()
|
||||
import System.Nix.Arbitrary.DerivedPath ()
|
||||
import System.Nix.Arbitrary.Hash ()
|
||||
import System.Nix.Arbitrary.OutputName ()
|
||||
import System.Nix.Arbitrary.Realisation ()
|
||||
import System.Nix.Arbitrary.Signature ()
|
||||
import System.Nix.Arbitrary.Store.Types ()
|
||||
import System.Nix.Arbitrary.StorePath ()
|
||||
|
@ -7,7 +7,6 @@ import System.Nix.Base
|
||||
|
||||
import Test.QuickCheck (Arbitrary(..))
|
||||
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
|
||||
import Test.QuickCheck.Instances ()
|
||||
|
||||
deriving via GenericArbitrary BaseEncoding
|
||||
instance Arbitrary BaseEncoding
|
||||
|
@ -3,11 +3,17 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module System.Nix.Arbitrary.Build where
|
||||
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Text.Arbitrary ()
|
||||
import Test.QuickCheck (Arbitrary(..), scale, suchThat)
|
||||
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
|
||||
import System.Nix.Arbitrary.OutputName ()
|
||||
import System.Nix.Arbitrary.Realisation ()
|
||||
import System.Nix.Arbitrary.UTCTime ()
|
||||
|
||||
import System.Nix.Build
|
||||
|
||||
import Test.QuickCheck (Arbitrary(..))
|
||||
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
|
||||
import Test.QuickCheck.Instances ()
|
||||
import qualified Data.Time.Clock.POSIX
|
||||
|
||||
deriving via GenericArbitrary BuildMode
|
||||
instance Arbitrary BuildMode
|
||||
@ -15,5 +21,17 @@ deriving via GenericArbitrary BuildMode
|
||||
deriving via GenericArbitrary BuildStatus
|
||||
instance Arbitrary BuildStatus
|
||||
|
||||
deriving via GenericArbitrary BuildResult
|
||||
instance Arbitrary BuildResult
|
||||
instance Arbitrary BuildResult where
|
||||
arbitrary = do
|
||||
buildResultStatus <- arbitrary
|
||||
buildResultErrorMessage <- arbitrary
|
||||
buildResultTimesBuilt <- arbitrary `suchThat` (/= Just 0)
|
||||
buildResultIsNonDeterministic <- arbitrary `suchThat` (/= Nothing)
|
||||
buildResultStartTime <- arbitrary `suchThat` (/= Just t0)
|
||||
buildResultStopTime <- arbitrary `suchThat` (/= Just t0)
|
||||
buildResultBuiltOutputs <- scale (`div` 10) (arbitrary `suchThat` (/= Nothing))
|
||||
|
||||
pure BuildResult{..}
|
||||
where
|
||||
t0 :: UTCTime
|
||||
t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0
|
||||
|
@ -4,12 +4,13 @@
|
||||
module System.Nix.Arbitrary.Derivation where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Arbitrary ()
|
||||
import Data.Vector.Arbitrary ()
|
||||
import System.Nix.Derivation
|
||||
import System.Nix.StorePath (StorePath)
|
||||
|
||||
import Test.QuickCheck (Arbitrary(..))
|
||||
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
|
||||
import Test.QuickCheck.Instances ()
|
||||
import System.Nix.Arbitrary.StorePath ()
|
||||
|
||||
deriving via GenericArbitrary (Derivation StorePath Text)
|
||||
|
@ -3,13 +3,20 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module System.Nix.Arbitrary.DerivedPath where
|
||||
|
||||
import Test.QuickCheck (Arbitrary)
|
||||
import qualified Data.Set
|
||||
import Test.QuickCheck (Arbitrary(..), oneof)
|
||||
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
|
||||
import System.Nix.Arbitrary.OutputName ()
|
||||
import System.Nix.Arbitrary.StorePath ()
|
||||
import System.Nix.DerivedPath (DerivedPath, OutputsSpec)
|
||||
import System.Nix.DerivedPath (DerivedPath, OutputsSpec(..))
|
||||
|
||||
deriving via GenericArbitrary OutputsSpec
|
||||
instance Arbitrary OutputsSpec
|
||||
instance Arbitrary OutputsSpec where
|
||||
arbitrary = oneof
|
||||
[ pure OutputsSpec_All
|
||||
, OutputsSpec_Names
|
||||
. Data.Set.fromList
|
||||
<$> ((:) <$> arbitrary <*> arbitrary)
|
||||
]
|
||||
|
||||
deriving via GenericArbitrary DerivedPath
|
||||
instance Arbitrary DerivedPath
|
||||
|
@ -4,13 +4,13 @@
|
||||
module System.Nix.Arbitrary.Hash where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Arbitrary ()
|
||||
import Crypto.Hash (Digest, MD5(..), SHA1(..), SHA256(..), SHA512(..))
|
||||
import Data.Dependent.Sum (DSum((:=>)))
|
||||
import Data.Some (Some(Some))
|
||||
import System.Nix.Hash (HashAlgo(..))
|
||||
|
||||
import Test.QuickCheck (Arbitrary(arbitrary), oneof)
|
||||
import Test.QuickCheck.Instances ()
|
||||
|
||||
import qualified Crypto.Hash
|
||||
|
||||
|
22
hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs
Normal file
22
hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs
Normal file
@ -0,0 +1,22 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module System.Nix.Arbitrary.OutputName where
|
||||
|
||||
import System.Nix.OutputName (OutputName)
|
||||
import qualified Data.Text
|
||||
import qualified System.Nix.OutputName
|
||||
|
||||
import Test.QuickCheck (Arbitrary(arbitrary), choose, elements, vectorOf)
|
||||
|
||||
instance Arbitrary OutputName where
|
||||
arbitrary =
|
||||
either (error . show) id
|
||||
. System.Nix.OutputName.mkOutputName
|
||||
. Data.Text.pack <$> ((:) <$> s1 <*> limited sn)
|
||||
where
|
||||
alphanum = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']
|
||||
s1 = elements $ alphanum <> "+-_?="
|
||||
sn = elements $ alphanum <> "+-._?="
|
||||
limited n = do
|
||||
k <- choose (0, 210)
|
||||
vectorOf k n
|
27
hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs
Normal file
27
hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs
Normal file
@ -0,0 +1,27 @@
|
||||
-- due to Illegal equational constraint Test.QuickCheck.Arbitrary.Generic.TypesDiffer
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
-- due to recent generic-arbitrary
|
||||
{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module System.Nix.Arbitrary.Realisation where
|
||||
|
||||
import System.Nix.Arbitrary.Hash ()
|
||||
import System.Nix.Arbitrary.OutputName ()
|
||||
import System.Nix.Arbitrary.Signature ()
|
||||
import System.Nix.Arbitrary.StorePath ()
|
||||
import System.Nix.Realisation (DerivationOutput, Realisation)
|
||||
|
||||
import Test.QuickCheck (Arbitrary(..))
|
||||
import Test.QuickCheck.Arbitrary.Generic (Arg, GenericArbitrary(..), genericArbitrary, genericShrink)
|
||||
|
||||
instance
|
||||
( Arg (DerivationOutput outputName) outputName
|
||||
, Arbitrary outputName
|
||||
) =>
|
||||
Arbitrary (DerivationOutput outputName)
|
||||
where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
deriving via GenericArbitrary Realisation
|
||||
instance Arbitrary Realisation
|
@ -9,7 +9,6 @@ import Crypto.Random (drgNewTest, withDRG)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as Text
|
||||
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
|
||||
import Test.QuickCheck.Instances ()
|
||||
import Test.QuickCheck
|
||||
|
||||
import System.Nix.Signature
|
||||
|
@ -15,7 +15,7 @@ import System.Nix.StorePath (StoreDir(..)
|
||||
)
|
||||
import qualified System.Nix.StorePath
|
||||
|
||||
import Test.QuickCheck (Arbitrary(arbitrary), elements, listOf, oneof)
|
||||
import Test.QuickCheck (Arbitrary(arbitrary), choose, elements, oneof, vectorOf)
|
||||
|
||||
instance Arbitrary StoreDir where
|
||||
arbitrary =
|
||||
@ -32,12 +32,15 @@ instance Arbitrary StorePath where
|
||||
instance Arbitrary StorePathName where
|
||||
arbitrary =
|
||||
either undefined id
|
||||
. System.Nix.StorePath.makeStorePathName
|
||||
. Data.Text.pack <$> ((:) <$> s1 <*> listOf sn)
|
||||
. System.Nix.StorePath.mkStorePathName
|
||||
. Data.Text.pack <$> ((:) <$> s1 <*> limited sn)
|
||||
where
|
||||
alphanum = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']
|
||||
s1 = elements $ alphanum <> "+-_?="
|
||||
sn = elements $ alphanum <> "+-._?="
|
||||
s1 = elements $ alphanum <> "+-_?="
|
||||
sn = elements $ alphanum <> "+-._?="
|
||||
limited n = do
|
||||
k <- choose (0, 210)
|
||||
vectorOf k n
|
||||
|
||||
instance Arbitrary StorePathHashPart where
|
||||
arbitrary =
|
||||
|
@ -4,20 +4,32 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module System.Nix.Arbitrary.StorePath.Metadata where
|
||||
|
||||
import Data.Dependent.Sum (DSum((:=>)))
|
||||
import Data.HashSet.Arbitrary ()
|
||||
import System.Nix.Arbitrary.ContentAddress ()
|
||||
import System.Nix.Arbitrary.Hash ()
|
||||
import System.Nix.Arbitrary.Signature ()
|
||||
import System.Nix.Arbitrary.StorePath ()
|
||||
import System.Nix.Arbitrary.UTCTime ()
|
||||
import System.Nix.StorePath (StorePath)
|
||||
import System.Nix.StorePath.Metadata (Metadata, StorePathTrust)
|
||||
import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust)
|
||||
|
||||
import Test.QuickCheck (Arbitrary(..))
|
||||
import qualified System.Nix.Hash
|
||||
|
||||
import Test.QuickCheck (Arbitrary(..), suchThat)
|
||||
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
|
||||
import Test.QuickCheck.Instances ()
|
||||
|
||||
deriving via GenericArbitrary StorePathTrust
|
||||
instance Arbitrary StorePathTrust
|
||||
|
||||
deriving via GenericArbitrary (Metadata StorePath)
|
||||
instance Arbitrary (Metadata StorePath)
|
||||
|
||||
instance Arbitrary (Metadata StorePath) where
|
||||
arbitrary = do
|
||||
metadataDeriverPath <- arbitrary
|
||||
metadataNarHash <- (System.Nix.Hash.HashAlgo_SHA256 :=>) <$> arbitrary
|
||||
metadataReferences <- arbitrary
|
||||
metadataRegistrationTime <- arbitrary
|
||||
metadataNarBytes <- arbitrary `suchThat` (/= Just 0)
|
||||
metadataTrust <- arbitrary
|
||||
metadataSigs <- arbitrary
|
||||
metadataContentAddress <- arbitrary
|
||||
pure Metadata{..}
|
||||
|
26
hnix-store-tests/src/System/Nix/Arbitrary/UTCTime.hs
Normal file
26
hnix-store-tests/src/System/Nix/Arbitrary/UTCTime.hs
Normal file
@ -0,0 +1,26 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
-- Stolen from quickcheck-instances (BSD-3)
|
||||
-- UTCTime/DiffTime slightly modified to produce
|
||||
-- values rounded to whole seconds
|
||||
module System.Nix.Arbitrary.UTCTime where
|
||||
|
||||
import Data.Time (Day(..), DiffTime, UTCTime(..))
|
||||
import Test.QuickCheck (Arbitrary(..))
|
||||
|
||||
instance Arbitrary Day where
|
||||
arbitrary = ModifiedJulianDay <$> (2000 +) <$> arbitrary
|
||||
shrink = (ModifiedJulianDay <$>) . shrink . Data.Time.toModifiedJulianDay
|
||||
|
||||
instance Arbitrary DiffTime where
|
||||
-- without abs something weird happens, try it
|
||||
arbitrary = fromInteger . abs <$> arbitrary
|
||||
|
||||
instance Arbitrary UTCTime where
|
||||
arbitrary =
|
||||
UTCTime
|
||||
<$> arbitrary
|
||||
<*> arbitrary
|
||||
shrink ut@(UTCTime day dayTime) =
|
||||
[ ut { Data.Time.utctDay = d' } | d' <- shrink day ]
|
||||
++ [ ut { Data.Time.utctDayTime = t' } | t' <- shrink dayTime ]
|
||||
|
@ -1,5 +1,6 @@
|
||||
module Test.Hspec.Nix
|
||||
( roundtrips
|
||||
( forceRight
|
||||
, roundtrips
|
||||
) where
|
||||
|
||||
import Test.Hspec (Expectation, shouldBe)
|
||||
@ -18,3 +19,11 @@ roundtrips
|
||||
-> Expectation
|
||||
roundtrips encode decode x =
|
||||
decode (encode x) `shouldBe` pure x
|
||||
|
||||
forceRight
|
||||
:: Show a
|
||||
=> Either a b
|
||||
-> b
|
||||
forceRight = \case
|
||||
Right x -> x
|
||||
Left e -> error $ "forceRight failed: " ++ show e
|
||||
|
@ -1,26 +1,17 @@
|
||||
module DerivedPathSpec where
|
||||
|
||||
import Data.Default.Class (Default(def))
|
||||
import Test.Hspec (Spec, describe, shouldBe)
|
||||
import Test.Hspec (Spec, describe)
|
||||
import Test.Hspec.QuickCheck (prop)
|
||||
import Test.QuickCheck (Arbitrary(arbitrary), forAll, suchThat)
|
||||
import Test.Hspec.Nix (roundtrips)
|
||||
|
||||
import System.Nix.Arbitrary ()
|
||||
import System.Nix.DerivedPath (DerivedPath(..), OutputsSpec(..))
|
||||
|
||||
import qualified Data.Set
|
||||
import qualified System.Nix.DerivedPath
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "DerivedPath" $ do
|
||||
prop "roundtrips" $
|
||||
forAll (arbitrary `suchThat` nonEmptyOutputsSpec_Names) $ \p ->
|
||||
System.Nix.DerivedPath.parseDerivedPath def
|
||||
(System.Nix.DerivedPath.derivedPathToText def p)
|
||||
`shouldBe` pure p
|
||||
where
|
||||
nonEmptyOutputsSpec_Names :: DerivedPath -> Bool
|
||||
nonEmptyOutputsSpec_Names (DerivedPath_Built _ (OutputsSpec_Names set)) =
|
||||
not $ Data.Set.null set
|
||||
nonEmptyOutputsSpec_Names _ = True
|
||||
prop "roundtrips" $ \sd ->
|
||||
roundtrips
|
||||
(System.Nix.DerivedPath.derivedPathToText sd)
|
||||
(System.Nix.DerivedPath.parseDerivedPath sd)
|
||||
|
26
hnix-store-tests/tests/RealisationSpec.hs
Normal file
26
hnix-store-tests/tests/RealisationSpec.hs
Normal file
@ -0,0 +1,26 @@
|
||||
module RealisationSpec where
|
||||
|
||||
import Test.Hspec (Spec, describe)
|
||||
import Test.Hspec.QuickCheck (prop)
|
||||
import Test.Hspec.Nix (roundtrips)
|
||||
|
||||
import System.Nix.Arbitrary ()
|
||||
|
||||
import qualified Data.Text.Lazy
|
||||
import qualified Data.Text.Lazy.Builder
|
||||
import qualified System.Nix.OutputName
|
||||
import qualified System.Nix.Realisation
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "DerivationOutput" $ do
|
||||
prop "roundtrips" $
|
||||
roundtrips
|
||||
( Data.Text.Lazy.toStrict
|
||||
. Data.Text.Lazy.Builder.toLazyText
|
||||
. System.Nix.Realisation.derivationOutputBuilder
|
||||
System.Nix.OutputName.unOutputName
|
||||
)
|
||||
( System.Nix.Realisation.derivationOutputParser
|
||||
System.Nix.OutputName.mkOutputName
|
||||
)
|
@ -4,10 +4,12 @@ import Test.Hspec (Spec, describe)
|
||||
import Test.Hspec.Nix (roundtrips)
|
||||
import Test.Hspec.QuickCheck (prop)
|
||||
|
||||
import System.Nix.Signature (signatureToText, parseSignature)
|
||||
import System.Nix.Signature (signatureToText, parseSignature, narSignatureToText, parseNarSignature)
|
||||
import System.Nix.Arbitrary ()
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "Signature" $ do
|
||||
prop "roundtrips" $ roundtrips signatureToText parseSignature
|
||||
describe "NarSignature" $ do
|
||||
prop "roundtrips" $ roundtrips narSignatureToText parseNarSignature
|
||||
|
23
overlay.nix
23
overlay.nix
@ -23,17 +23,12 @@ in
|
||||
sha256 = "sha256-AnjaUzSlsLi3lIURrEfs92Jo5FzX49RyNdfDSfFV3Kk=";
|
||||
} {};
|
||||
|
||||
# srk 2023-11-19: default in unstable is 0.1.1.1 which
|
||||
# fails to compile test on ghc8107
|
||||
# but for for ghc963 we hit
|
||||
# https://github.com/obsidiansystems/dependent-sum-template/issues/10
|
||||
# so we use 0.1.1.1 for ghc963 and 0.2.0.0 for the rest
|
||||
# - some weird interaction in unstable as this builds
|
||||
# with cabal and 0.2.0.0
|
||||
dependent-sum-template =
|
||||
if compiler == "ghc8107" || compiler == "ghc902" || compiler == "ghc928"
|
||||
then hsuper.dependent-sum-template_0_2_0_0
|
||||
else hsuper.dependent-sum-template;
|
||||
# srk 2023-12-06: until in unstable
|
||||
dependent-sum-template = hself.callHackageDirect
|
||||
{ pkg = "dependent-sum-template";
|
||||
ver = "0.2.0.1";
|
||||
sha256 = "sha256-quwgFuEBrK96JZenJZcyfk/O0Gp+ukwKEpe1hMqDbIg=";
|
||||
} {};
|
||||
|
||||
# srk 2023-11-19: wider unix bound via CPP
|
||||
# Required for ghc963 since linux-namespaces is pinned
|
||||
@ -56,6 +51,12 @@ in
|
||||
[
|
||||
haskellLib.compose.buildFromSdist
|
||||
];
|
||||
hnix-store-json =
|
||||
lib.pipe
|
||||
(hself.callCabal2nix "hnix-store-json" ./hnix-store-json {})
|
||||
[
|
||||
haskellLib.compose.buildFromSdist
|
||||
];
|
||||
hnix-store-nar =
|
||||
lib.pipe
|
||||
(hself.callCabal2nix "hnix-store-nar" ./hnix-store-nar {})
|
||||
|
Loading…
Reference in New Issue
Block a user