diff --git a/cabal.project b/cabal.project index bc00a4e7..6c26f75b 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/cabal.project.local.ci b/cabal.project.local.ci index d97bf7d3..764e06a8 100644 --- a/cabal.project.local.ci +++ b/cabal.project.local.ci @@ -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 diff --git a/default.nix b/default.nix index 65722b4d..f42d46ec 100644 --- a/default.nix +++ b/default.nix @@ -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 diff --git a/docs/01-Contributors.org b/docs/01-Contributors.org index 3302cc49..20d88bf8 100644 --- a/docs/01-Contributors.org +++ b/docs/01-Contributors.org @@ -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 diff --git a/hie.yaml b/hie.yaml index 9ba8d508..dc60850e 100644 --- a/hie.yaml +++ b/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" diff --git a/hnix-store-core/CHANGELOG.md b/hnix-store-core/CHANGELOG.md index a9cd80de..e9e7cfdc 100644 --- a/hnix-store-core/CHANGELOG.md +++ b/hnix-store-core/CHANGELOG.md @@ -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) diff --git a/hnix-store-core/hnix-store-core.cabal b/hnix-store-core/hnix-store-core.cabal index dcbffbdd..c5caefd8 100644 --- a/hnix-store-core/hnix-store-core.cabal +++ b/hnix-store-core/hnix-store-core.cabal @@ -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: diff --git a/hnix-store-core/src/System/Nix/Build.hs b/hnix-store-core/src/System/Nix/Build.hs index abd6af31..248732d9 100644 --- a/hnix-store-core/src/System/Nix/Build.hs +++ b/hnix-store-core/src/System/Nix/Build.hs @@ -5,34 +5,40 @@ Maintainer : srk 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 diff --git a/hnix-store-core/src/System/Nix/DerivedPath.hs b/hnix-store-core/src/System/Nix/DerivedPath.hs index df12e181..c53831f9 100644 --- a/hnix-store-core/src/System/Nix/DerivedPath.hs +++ b/hnix-store-core/src/System/Nix/DerivedPath.hs @@ -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 diff --git a/hnix-store-core/src/System/Nix/Fingerprint.hs b/hnix-store-core/src/System/Nix/Fingerprint.hs index 34167197..4eb7f309 100644 --- a/hnix-store-core/src/System/Nix/Fingerprint.hs +++ b/hnix-store-core/src/System/Nix/Fingerprint.hs @@ -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 diff --git a/hnix-store-core/src/System/Nix/OutputName.hs b/hnix-store-core/src/System/Nix/OutputName.hs new file mode 100644 index 00000000..8634d5d2 --- /dev/null +++ b/hnix-store-core/src/System/Nix/OutputName.hs @@ -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 diff --git a/hnix-store-core/src/System/Nix/Realisation.hs b/hnix-store-core/src/System/Nix/Realisation.hs new file mode 100644 index 00000000..383fd178 --- /dev/null +++ b/hnix-store-core/src/System/Nix/Realisation.hs @@ -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) diff --git a/hnix-store-core/src/System/Nix/Signature.hs b/hnix-store-core/src/System/Nix/Signature.hs index 3a16c52e..c8e55b73 100644 --- a/hnix-store-core/src/System/Nix/Signature.hs +++ b/hnix-store-core/src/System/Nix/Signature.hs @@ -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) diff --git a/hnix-store-core/src/System/Nix/StorePath.hs b/hnix-store-core/src/System/Nix/StorePath.hs index bbc3ff45..18bcf11d 100644 --- a/hnix-store-core/src/System/Nix/StorePath.hs +++ b/hnix-store-core/src/System/Nix/StorePath.hs @@ -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 - -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 +-- or fail with @InvalidNameError@ if it isn't valid +mkStorePathName :: Text -> Either InvalidNameError StorePathName +mkStorePathName = fmap StorePathName . parseNameText + +-- | 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) diff --git a/hnix-store-core/src/System/Nix/StorePath/Metadata.hs b/hnix-store-core/src/System/Nix/StorePath/Metadata.hs index 795bcc61..552ca68e 100644 --- a/hnix-store-core/src/System/Nix/StorePath/Metadata.hs +++ b/hnix-store-core/src/System/Nix/StorePath/Metadata.hs @@ -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) diff --git a/hnix-store-core/tests/Fingerprint.hs b/hnix-store-core/tests/Fingerprint.hs index ad949b47..77c890d1 100644 --- a/hnix-store-core/tests/Fingerprint.hs +++ b/hnix-store-core/tests/Fingerprint.hs @@ -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" diff --git a/hnix-store-core/tests/Signature.hs b/hnix-store-core/tests/Signature.hs index fa88717c..5841a2be 100644 --- a/hnix-store-core/tests/Signature.hs +++ b/hnix-store-core/tests/Signature.hs @@ -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 diff --git a/hnix-store-core/tests/StorePath.hs b/hnix-store-core/tests/StorePath.hs new file mode 100644 index 00000000..46a28f9f --- /dev/null +++ b/hnix-store-core/tests/StorePath.hs @@ -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 "!#@") diff --git a/hnix-store-json/CHANGELOG.md b/hnix-store-json/CHANGELOG.md new file mode 100644 index 00000000..b8e0d5fa --- /dev/null +++ b/hnix-store-json/CHANGELOG.md @@ -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 + diff --git a/hnix-store-json/LICENSE b/hnix-store-json/LICENSE new file mode 100644 index 00000000..6b9e8a2a --- /dev/null +++ b/hnix-store-json/LICENSE @@ -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. diff --git a/hnix-store-json/README.md b/hnix-store-json/README.md new file mode 100644 index 00000000..ad23e4b1 --- /dev/null +++ b/hnix-store-json/README.md @@ -0,0 +1,3 @@ +# hnix-store-json + +Aeson instances for core types. diff --git a/hnix-store-json/hnix-store-json.cabal b/hnix-store-json/hnix-store-json.cabal new file mode 100644 index 00000000..08c4289f --- /dev/null +++ b/hnix-store-json/hnix-store-json.cabal @@ -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 diff --git a/hnix-store-json/src/System/Nix/JSON.hs b/hnix-store-json/src/System/Nix/JSON.hs new file mode 100644 index 00000000..12a951db --- /dev/null +++ b/hnix-store-json/src/System/Nix/JSON.hs @@ -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 diff --git a/hnix-store-json/tests/JSONSpec.hs b/hnix-store-json/tests/JSONSpec.hs new file mode 100644 index 00000000..6aad8a84 --- /dev/null +++ b/hnix-store-json/tests/JSONSpec.hs @@ -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\"}}" diff --git a/hnix-store-json/tests/Spec.hs b/hnix-store-json/tests/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/hnix-store-json/tests/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/hnix-store-readonly/tests/ReadOnlySpec.hs b/hnix-store-readonly/tests/ReadOnlySpec.hs index 6bab0141..6d449672 100644 --- a/hnix-store-readonly/tests/ReadOnlySpec.hs +++ b/hnix-store-readonly/tests/ReadOnlySpec.hs @@ -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 = diff --git a/hnix-store-remote/README.md b/hnix-store-remote/README.md index d8fa4d59..cb545cdc 100644 --- a/hnix-store-remote/README.md +++ b/hnix-store-remote/README.md @@ -16,6 +16,7 @@ via `nix-daemon`. import Control.Monad (void) import Control.Monad.IO.Class (liftIO) +import System.Nix.StorePath (mkStorePathName) import System.Nix.Store.Remote main :: IO () @@ -25,6 +26,12 @@ main = do roots <- findRoots liftIO $ print roots - res <- addTextToStore "hnix-store" "test" mempty RepairMode_DontRepair + res <- case mkStorePathName "hnix-store" of + Left e -> error (show e) + Right name -> + addTextToStore + (StoreText name "Hello World!") + mempty + RepairMode_DontRepair liftIO $ print res ``` diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index e6d5029d..5546c10e 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -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 diff --git a/hnix-store-remote/src/Data/Serializer.hs b/hnix-store-remote/src/Data/Serializer.hs index ffd8baa8..1a1c6012 100644 --- a/hnix-store-remote/src/Data/Serializer.hs +++ b/hnix-store-remote/src/Data/Serializer.hs @@ -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 diff --git a/hnix-store-remote/src/Data/Serializer/Example.hs b/hnix-store-remote/src/Data/Serializer/Example.hs index b02df4e8..d7709d34 100644 --- a/hnix-store-remote/src/Data/Serializer/Example.hs +++ b/hnix-store-remote/src/Data/Serializer/Example.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote.hs b/hnix-store-remote/src/System/Nix/Store/Remote.hs index 782448bd..cf4b23eb 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote.hs @@ -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 - --- | Pack `Nar` and add it to the store. -addToStore - :: forall a - . (NamedAlgo a) - => StorePathName -- ^ Name part of the newly created `StorePath` - -> NarSource MonadStore -- ^ provide nar stream - -> FileIngestionMethod -- ^ Add target directory recursively - -> RepairMode -- ^ Only used by local store backend - -> MonadStore StorePath -addToStore name source recursive repair = do - Control.Monad.when (repair == RepairMode_DoRepair) - $ error "repairing is not supported when building through the Nix daemon" - - runOpArgsIO AddToStore $ \yield -> do - yield $ Data.Serialize.Put.runPut $ do - putText $ System.Nix.StorePath.unStorePathName name - putBool - $ not - $ System.Nix.Hash.algoName @a == "sha256" - && recursive == FileIngestionMethod_FileRecursive - putBool (recursive == FileIngestionMethod_FileRecursive) - putText $ System.Nix.Hash.algoName @a - source yield - sockGetPath - --- | Add text to store. --- --- Reference accepts repair but only uses it --- to throw error in case of remote talking to nix-daemon. -addTextToStore - :: Text -- ^ Name of the text - -> Text -- ^ Actual text to add - -> HashSet StorePath -- ^ Set of `StorePath`s that the added text references - -> RepairMode -- ^ Repair mode, must be `RepairMode_DontRepair` for remote backend - -- (only valid for local store) - -> MonadStore StorePath -addTextToStore name text references' repair = do - Control.Monad.when (repair == RepairMode_DoRepair) - $ error "repairing is not supported when building through the Nix daemon" - - storeDir <- getStoreDir - runOpArgs AddTextToStore $ do - putText name - putText text - putPaths storeDir references' - sockGetPath - -addSignatures :: StorePath -> [ByteString] -> MonadStore () -addSignatures p signatures = do - storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs AddSignatures $ do - putPath storeDir p - putByteStrings signatures - -addIndirectRoot :: StorePath -> MonadStore () -addIndirectRoot pn = do - storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs AddIndirectRoot $ putPath storeDir pn - --- | Add temporary garbage collector root. --- --- This root is removed as soon as the client exits. -addTempRoot :: StorePath -> MonadStore () -addTempRoot pn = do - storeDir <- getStoreDir - Control.Monad.void $ simpleOpArgs 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 +import qualified Control.Exception +import qualified Network.Socket + +-- * Compat + +type MonadStore = RemoteStoreT StoreConfig IO + +-- * Runners + +runStore :: MonadStore a -> Run IO a +runStore = runStoreOpts defaultSockPath def + where + defaultSockPath :: String + defaultSockPath = "/nix/var/nix/daemon-socket/socket" + +runStoreOpts + :: FilePath + -> StoreDir + -> MonadStore a + -> Run IO a +runStoreOpts socketPath = + runStoreOpts' + Network.Socket.AF_UNIX + (SockAddrUnix socketPath) + +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) + +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 + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs index e1e7a018..0b9386fa 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Arbitrary.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs new file mode 100644 index 00000000..820747d3 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs new file mode 100644 index 00000000..8837c068 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client/Core.hs @@ -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 + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs index d2e5ffe0..4e9afa3d 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs index a2f54280..debe4e7d 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs @@ -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 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.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 Control.Monad.Trans.State.Strict (mapStateT) -import Control.Monad.Trans.Except (mapExceptT) -import Control.Monad.Trans.Reader (withReaderT) +import qualified Data.DList -import System.Nix.StorePath (HasStoreDir(..), StoreDir) -import System.Nix.Store.Remote.Types.Logger (Logger, isError) -import System.Nix.Store.Remote.Types.StoreConfig (StoreConfig(..)) +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) + } --- | Ask for a @StoreDir@ -getStoreDir :: (HasStoreDir r, MonadReader r m) => m StoreDir -getStoreDir = asks hasStoreDir +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 -type MonadStore a - = ExceptT - String - (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO)) - a + getStoreDir :: m StoreDir + default getStoreDir + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => m StoreDir + getStoreDir = lift getStoreDir --- | 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 } + getStoreSocket :: m Socket + default getStoreSocket + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => m Socket + getStoreSocket = lift getStoreSocket -gotError :: MonadStore Bool -gotError = gets (any isError . snd) + setNarSource :: NarSource IO -> m () + default setNarSource + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => NarSource IO + -> m () + setNarSource x = lift (setNarSource x) -getErrors :: MonadStore [Logger] -getErrors = gets (filter isError . snd) + takeNarSource :: m (Maybe (NarSource IO)) + default takeNarSource + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => m (Maybe (NarSource IO)) + takeNarSource = lift takeNarSource -getLog :: MonadStore [Logger] -getLog = gets snd + 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) -flushLog :: MonadStore () -flushLog = modify (\(a, _b) -> (a, [])) + 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 -setData :: ByteString -> MonadStore () -setData x = modify (\(_, b) -> (Just x, b)) + clearDataSource :: m () + default clearDataSource + :: ( MonadTrans t + , MonadRemoteStoreR r m' + , m ~ t m' + ) + => m () + clearDataSource = lift clearDataSource -clearData :: MonadStore () -clearData = modify (\(_, b) -> (Nothing, b)) + 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@ +getProtoVersion + :: ( MonadRemoteStoreR r m + , HasProtoVersion r + ) + => m ProtoVersion +getProtoVersion = asks hasProtoVersion diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs deleted file mode 100644 index e830c4a8..00000000 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Protocol.hs +++ /dev/null @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs deleted file mode 100644 index f26e96e0..00000000 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -{-| -Description : Serialize instances for complex types -Maintainer : srk -|-} -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize/Prim.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serialize/Prim.hs deleted file mode 100644 index e69b92ec..00000000 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serialize/Prim.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-| -Description : Nix-like serialization primitives -Maintainer : srk -|-} -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs index f1b0ce33..42f32551 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -9,6 +9,8 @@ module System.Nix.Store.Remote.Serializer ( -- * NixSerializer NixSerializer + , mapReaderS + , mapErrorS -- * Errors , SError(..) -- ** Runners @@ -29,29 +31,39 @@ module System.Nix.Store.Remote.Serializer , set , hashSet , mapS + , vector + , json -- * ProtoVersion , protoVersion -- * StorePath , storePath + , maybePath , storePathHashPart , storePathName -- * Metadata , pathMetadata + -- * OutputName + , outputName + -- * Signatures + , signature + , narSignature -- * Some HashAlgo , someHashAlgo -- * Digest , digest + -- * DSum HashAlgo Digest + , namedDigest -- * Derivation , derivation -- * Derivation , derivedPath -- * Build , buildMode - , buildResult -- * Logger , LoggerSError(..) , activityID , maybeActivity + , activity , activityResult , field , trace @@ -60,62 +72,101 @@ module System.Nix.Store.Remote.Serializer , loggerOpCode , logger , verbosity + -- * Handshake + , HandshakeSError(..) + , workerMagic + , trustedFlag + -- * Worker protocol + , storeText + , workerOp + -- ** Request + , RequestSError(..) + , storeRequest + -- ** Reply + , ReplySError(..) + , opSuccess + -- *** Realisation + , derivationOutputTyped + , realisation + , realisationWithId + -- *** BuildResult + , buildResult + -- *** GCResult + , gcResult + -- *** GCResult + , gcRoot + -- *** Missing + , missing + -- *** Maybe (Metadata StorePath) + , maybePathMetadata ) where -import Control.Monad.Except (MonadError, throwError, withExceptT) +import Control.Monad.Except (MonadError, throwError, ) import Control.Monad.Reader (MonadReader) import Control.Monad.Trans (MonadTrans, lift) -import Control.Monad.Trans.Reader (ReaderT, runReaderT) -import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT) +import Control.Monad.Trans.Except (ExceptT, mapExceptT, runExceptT, withExceptT) import Crypto.Hash (Digest, HashAlgorithm, SHA256) +import Data.Aeson (FromJSON, ToJSON) import Data.ByteString (ByteString) import Data.Dependent.Sum (DSum((:=>))) import Data.Fixed (Uni) import Data.Hashable (Hashable) import Data.HashSet (HashSet) import Data.Map (Map) +import Data.Serializer import Data.Set (Set) -import Data.Some (Some) +import Data.Some (Some(Some)) import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) import Data.Time (NominalDiffTime, UTCTime) import Data.Vector (Vector) import Data.Word (Word8, Word32, Word64) import GHC.Generics (Generic) +import System.Nix.Base (BaseEncoding(Base16, NixBase32)) +import System.Nix.Build (BuildMode, BuildResult(..)) +import System.Nix.ContentAddress (ContentAddress) +import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) +import System.Nix.DerivedPath (DerivedPath(..), ParseOutputsError) +import System.Nix.Hash (HashAlgo(..)) +import System.Nix.JSON () +import System.Nix.OutputName (OutputName) +import System.Nix.Realisation (DerivationOutputError, Realisation(..)) +import System.Nix.Signature (Signature, NarSignature) +import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..)) +import System.Nix.StorePath (HasStoreDir(..), InvalidNameError, InvalidPathError, StorePath, StorePathHashPart, StorePathName) +import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) +import System.Nix.Store.Remote.Types import qualified Control.Monad import qualified Control.Monad.Reader +import qualified Data.Aeson import qualified Data.Attoparsec.Text +import qualified Data.Bifunctor import qualified Data.Bits import qualified Data.ByteString +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy +import qualified Data.Coerce import qualified Data.HashSet import qualified Data.Map.Strict +import qualified Data.Maybe import qualified Data.Serialize.Get import qualified Data.Serialize.Put import qualified Data.Set +import qualified Data.Some import qualified Data.Text import qualified Data.Text.Encoding +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder import qualified Data.Time.Clock.POSIX import qualified Data.Vector - -import Data.Serializer -import System.Nix.Base (BaseEncoding(NixBase32)) -import System.Nix.Build (BuildMode, BuildResult(..)) -import System.Nix.ContentAddress (ContentAddress) -import System.Nix.Derivation (Derivation(..), DerivationOutput(..)) -import System.Nix.DerivedPath (DerivedPath, ParseOutputsError) -import System.Nix.Hash (HashAlgo) -import System.Nix.Signature (NarSignature) -import System.Nix.StorePath (HasStoreDir(..), InvalidPathError, StorePath, StorePathHashPart, StorePathName) -import System.Nix.StorePath.Metadata (Metadata(..), StorePathTrust(..)) -import System.Nix.Store.Remote.Types - -import qualified Data.Coerce -import qualified Data.Bifunctor -import qualified Data.Some import qualified System.Nix.Base import qualified System.Nix.ContentAddress import qualified System.Nix.DerivedPath import qualified System.Nix.Hash +import qualified System.Nix.OutputName +import qualified System.Nix.Realisation import qualified System.Nix.Signature import qualified System.Nix.StorePath @@ -145,16 +196,44 @@ runSerialT r = . runExceptT . _unSerialT -mapError +mapErrorST :: Functor m => (e -> e') -> SerialT r e m a -> SerialT r e' m a -mapError f = +mapErrorST f = + SerialT + . withExceptT f + . _unSerialT + +mapErrorS + :: (e -> e') + -> NixSerializer r e a + -> NixSerializer r e' a +mapErrorS f s = Serializer + { getS = mapErrorST f $ getS s + , putS = mapErrorST f . putS s + } + +mapReaderST + :: Functor m + => (r' -> r) + -> SerialT r e m a + -> SerialT r' e m a +mapReaderST f = SerialT - . withExceptT f + . (mapExceptT . withReaderT) f . _unSerialT +mapReaderS + :: (r' -> r) + -> NixSerializer r e a + -> NixSerializer r' e a +mapReaderS f s = Serializer + { getS = mapReaderST f $ getS s + , putS = mapReaderST f . putS s + } + -- * NixSerializer type NixSerializer r e = Serializer (SerialT r e) @@ -170,14 +249,17 @@ data SError } | SError_ContentAddress String | SError_DerivedPath ParseOutputsError + | SError_DerivationOutput DerivationOutputError | SError_Digest String | SError_EnumOutOfMinBound Int | SError_EnumOutOfMaxBound Int | SError_HashAlgo String | SError_IllegalBool Word64 | SError_InvalidNixBase32 + | SError_JSONDecoding String | SError_NarHashMustBeSHA256 | SError_NotYetImplemented String (ForPV ProtoVersion) + | SError_Name InvalidNameError | SError_Path InvalidPathError | SError_Signature String deriving (Eq, Ord, Generic, Show) @@ -284,13 +366,20 @@ text = mapIsoSerializer Data.Text.Encoding.encodeUtf8 byteString +-- TODO Parser Builder +_textBuilder :: NixSerializer r SError Builder +_textBuilder = Serializer + { getS = Data.Text.Lazy.Builder.fromText <$> getS text + , putS = putS text . Data.Text.Lazy.toStrict . Data.Text.Lazy.Builder.toLazyText + } + maybeText :: NixSerializer r SError (Maybe Text) maybeText = mapIsoSerializer (\case t | Data.Text.null t -> Nothing t | otherwise -> Just t ) - (maybe mempty id) + (Data.Maybe.fromMaybe mempty) text -- * UTCTime @@ -373,6 +462,22 @@ vector = Data.Vector.toList . list +json + :: ( FromJSON a + , ToJSON a + ) + => NixSerializer r SError a +json = + mapPrismSerializer + ( Data.Bifunctor.first SError_JSONDecoding + . Data.Aeson.eitherDecode + ) + Data.Aeson.encode + $ mapIsoSerializer + Data.ByteString.Lazy.fromStrict + Data.ByteString.Lazy.toStrict + byteString + -- * ProtoVersion -- protoVersion_major & 0xFF00 @@ -409,6 +514,27 @@ storePath = Serializer $ System.Nix.StorePath.storePathToRawFilePath sd p } +maybePath + :: HasStoreDir r + => NixSerializer r SError (Maybe StorePath) +maybePath = Serializer + { getS = do + getS maybeText >>= \case + Nothing -> pure Nothing + Just t -> do + sd <- Control.Monad.Reader.asks hasStoreDir + either + (throwError . SError_Path) + (pure . pure) + $ System.Nix.StorePath.parsePathFromText sd t + + , putS = \case + Nothing -> putS maybeText Nothing + Just p -> do + sd <- Control.Monad.Reader.asks hasStoreDir + putS text $ System.Nix.StorePath.storePathToText sd p + } + storePathHashPart :: NixSerializer r SError StorePathHashPart storePathHashPart = mapIsoSerializer @@ -423,8 +549,8 @@ storePathHashPart = storePathName :: NixSerializer r SError StorePathName storePathName = mapPrismSerializer - (Data.Bifunctor.first SError_Path - . System.Nix.StorePath.makeStorePathName) + (Data.Bifunctor.first SError_Name + . System.Nix.StorePath.mkStorePathName) System.Nix.StorePath.unStorePathName text @@ -433,42 +559,44 @@ pathMetadata => NixSerializer r SError (Metadata StorePath) pathMetadata = Serializer { getS = do - deriverPath <- getS maybePath + metadataDeriverPath <- getS maybePath - digest' <- getS $ digest NixBase32 - let narHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest' + digest' <- getS $ digest Base16 + let metadataNarHash = System.Nix.Hash.HashAlgo_SHA256 :=> digest' - references <- getS $ hashSet storePath - registrationTime <- getS time - narBytes <- (\case - 0 -> Nothing - size -> Just size) <$> getS int - trust <- getS storePathTrust + metadataReferences <- getS $ hashSet storePath + metadataRegistrationTime <- getS time + metadataNarBytes <- + (\case + 0 -> Nothing + size -> Just size + ) <$> getS int + metadataTrust <- getS storePathTrust - sigs <- getS $ set signature - contentAddress <- getS maybeContentAddress + metadataSigs <- getS $ set narSignature + metadataContentAddress <- getS maybeContentAddress pure $ Metadata{..} , putS = \Metadata{..} -> do - putS maybePath deriverPath + putS maybePath metadataDeriverPath let putNarHash :: DSum HashAlgo Digest -> SerialT r SError PutM () putNarHash = \case System.Nix.Hash.HashAlgo_SHA256 :=> d - -> putS (digest @SHA256 NixBase32) d + -> putS (digest @SHA256 Base16) d _ -> throwError SError_NarHashMustBeSHA256 - putNarHash narHash + putNarHash metadataNarHash - putS (hashSet storePath) references - putS time registrationTime - putS int $ Prelude.maybe 0 id $ narBytes - putS storePathTrust trust - putS (set signature) sigs - putS maybeContentAddress contentAddress + putS (hashSet storePath) metadataReferences + putS time metadataRegistrationTime + putS int $ Data.Maybe.fromMaybe 0 metadataNarBytes + putS storePathTrust metadataTrust + putS (set narSignature) metadataSigs + putS maybeContentAddress metadataContentAddress } where maybeContentAddress @@ -485,27 +613,6 @@ pathMetadata = Serializer (fmap System.Nix.ContentAddress.buildContentAddress) maybeText - maybePath - :: HasStoreDir r - => NixSerializer r SError (Maybe StorePath) - maybePath = Serializer - { getS = do - getS maybeText >>= \case - Nothing -> pure Nothing - Just t -> do - sd <- Control.Monad.Reader.asks hasStoreDir - either - (throwError . SError_Path) - (pure . pure) - $ System.Nix.StorePath.parsePathFromText sd t - - , putS = \case - Nothing -> putS maybeText Nothing - Just p -> do - sd <- Control.Monad.Reader.asks hasStoreDir - putS text $ System.Nix.StorePath.storePathToText sd p - } - storePathTrust :: NixSerializer r SError StorePathTrust storePathTrust = @@ -514,15 +621,37 @@ pathMetadata = Serializer (\case BuiltElsewhere -> False; BuiltLocally -> True) bool - signature - :: NixSerializer r SError NarSignature - signature = - mapPrismSerializer - (Data.Bifunctor.first SError_Signature - . Data.Attoparsec.Text.parseOnly - System.Nix.Signature.signatureParser) - (System.Nix.Signature.signatureToText) - text +-- * OutputName + +outputName :: NixSerializer r SError OutputName +outputName = + mapPrismSerializer + (Data.Bifunctor.first SError_Name + . System.Nix.OutputName.mkOutputName) + System.Nix.OutputName.unOutputName + text + +-- * Signatures + +signature + :: NixSerializer r SError Signature +signature = + mapPrismSerializer + (Data.Bifunctor.first SError_Signature + . Data.Attoparsec.Text.parseOnly + System.Nix.Signature.signatureParser) + (System.Nix.Signature.signatureToText) + text + +narSignature + :: NixSerializer r SError NarSignature +narSignature = + mapPrismSerializer + (Data.Bifunctor.first SError_Signature + . Data.Attoparsec.Text.parseOnly + System.Nix.Signature.narSignatureParser) + (System.Nix.Signature.narSignatureToText) + text -- * Some HashAlgo @@ -551,6 +680,28 @@ digest base = (System.Nix.Hash.encodeDigestWith base) $ text +-- * DSum HashAlgo Digest + +namedDigest :: NixSerializer r SError (DSum HashAlgo Digest) +namedDigest = Serializer + { getS = do + sriHash <- getS text + let (sriName, _h) = Data.Text.breakOn (Data.Text.singleton '-') sriHash + -- bit hacky since mkNamedDigest does the check + -- that the expected matches but we don't know + -- what we expect here (i.e. handle each HashAlgo) + case System.Nix.Hash.mkNamedDigest sriName sriHash of + Left e -> throwError $ SError_Digest e + Right x -> pure x + -- TODO: we also lack a builder for SRI hashes + -- , putS = putS textBuilder . System.Nix.Hash.algoDigestBuilder + , putS = \(algo :=> d) -> do + putS text + $ System.Nix.Hash.algoToText algo + <> (Data.Text.singleton '-') + <> System.Nix.Hash.encodeDigestWith NixBase32 d + } + derivationOutput :: HasStoreDir r => NixSerializer r SError (DerivationOutput StorePath Text) @@ -620,20 +771,17 @@ derivedPath = Serializer { getS = do pv <- Control.Monad.Reader.asks hasProtoVersion if pv < ProtoVersion 1 30 - then - throwError - $ SError_NotYetImplemented - "DerivedPath" - (ForPV_Older pv) + then DerivedPath_Opaque <$> getS storePath else getS derivedPathNew , putS = \d -> do pv <- Control.Monad.Reader.asks hasProtoVersion if pv < ProtoVersion 1 30 - then - throwError - $ SError_NotYetImplemented - "DerivedPath" - (ForPV_Older pv) + then case d of + DerivedPath_Opaque p -> putS storePath p + _ -> throwError + $ SError_NotYetImplemented + "DerivedPath_Built" + (ForPV_Older pv) else putS derivedPathNew d } @@ -642,31 +790,11 @@ derivedPath = Serializer buildMode :: NixSerializer r SError BuildMode buildMode = enum -buildResult :: NixSerializer r SError BuildResult -buildResult = Serializer - { getS = do - status <- getS enum - errorMessage <- getS maybeText - timesBuilt <- getS int - isNonDeterministic <- getS bool - startTime <- getS time - stopTime <- getS time - pure $ BuildResult{..} - - , putS = \BuildResult{..} -> do - putS enum status - putS maybeText errorMessage - putS int timesBuilt - putS bool isNonDeterministic - putS time startTime - putS time stopTime - } - -- * Logger data LoggerSError = LoggerSError_Prim SError - | LoggerSError_InvalidOpCode Int + | LoggerSError_InvalidOpCode Word64 | LoggerSError_TooOldForErrorInfo | LoggerSError_TooNewForBasicError | LoggerSError_UnknownLogFieldType Word8 @@ -676,7 +804,7 @@ mapPrimE :: Functor m => SerialT r SError m a -> SerialT r LoggerSError m a -mapPrimE = mapError LoggerSError_Prim +mapPrimE = mapErrorST LoggerSError_Prim maybeActivity :: NixSerializer r LoggerSError (Maybe Activity) maybeActivity = Serializer @@ -687,12 +815,12 @@ maybeActivity = Serializer Nothing -> putS (int @Int) 0 Just act -> putS activity act } - where - activity :: NixSerializer r LoggerSError Activity - activity = Serializer - { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100)) - , putS = putS int . (+100) . fromEnum - } + +activity :: NixSerializer r LoggerSError Activity +activity = Serializer + { getS = mapPrimE $ getS int >>= toEnumCheckBoundsM . (+(-100)) + , putS = putS int . (+100) . fromEnum + } activityID :: NixSerializer r LoggerSError ActivityID activityID = mapIsoSerializer ActivityID unActivityID int @@ -721,7 +849,7 @@ trace = Serializer traceHint <- mapPrimE $ getS text pure Trace{..} , putS = \Trace{..} -> do - maybe (putS (int @Int) 0) (putS int) $ tracePosition + putS int $ Data.Maybe.fromMaybe 0 tracePosition mapPrimE $ putS text traceHint } @@ -758,7 +886,7 @@ errorInfo = Serializer mapPrimE $ do putS text $ Data.Text.pack "Error" -- removed error name putS text errorInfoMessage - maybe (putS (int @Word8) 0) (putS int) errorInfoPosition + putS int $ Data.Maybe.fromMaybe 0 errorInfoPosition putS (list trace) errorInfoTraces } @@ -769,8 +897,8 @@ loggerOpCode = Serializer either (pure $ throwError (LoggerSError_InvalidOpCode c)) pure - $ intToLoggerOpCode c - , putS = putS int . loggerOpCodeToInt + $ word64ToLoggerOpCode c + , putS = putS int . loggerOpCodeToWord64 } logger @@ -821,8 +949,7 @@ logger = Serializer , putS = \case Logger_Next s -> do putS loggerOpCode LoggerOpCode_Next - mapError LoggerSError_Prim $ - putS text s + mapPrimE $ putS text s Logger_Read i -> do putS loggerOpCode LoggerOpCode_Read @@ -872,3 +999,533 @@ verbosity = Serializer { getS = mapPrimE $ getS enum , putS = mapPrimE . putS enum } + +-- * Handshake + +data HandshakeSError + = HandshakeSError_InvalidWorkerMagic Word64 + | HandshakeSError_InvalidTrustedFlag Word8 + deriving (Eq, Ord, Generic, Show) + +workerMagic :: NixSerializer r HandshakeSError WorkerMagic +workerMagic = Serializer + { getS = do + c <- getS int + either + (pure $ throwError (HandshakeSError_InvalidWorkerMagic c)) + pure + $ word64ToWorkerMagic c + , putS = putS int . workerMagicToWord64 + } + +trustedFlag :: NixSerializer r HandshakeSError (Maybe TrustedFlag) +trustedFlag = Serializer + { getS = do + n :: Word8 <- getS int + case n of + 0 -> return $ Nothing + 1 -> return $ Just TrustedFlag_Trusted + 2 -> return $ Just TrustedFlag_NotTrusted + _ -> throwError (HandshakeSError_InvalidTrustedFlag n) + , putS = \n -> putS int $ case n of + Nothing -> 0 :: Word8 + Just TrustedFlag_Trusted -> 1 + Just TrustedFlag_NotTrusted -> 2 + } + +-- * Worker protocol + +storeText :: NixSerializer r SError StoreText +storeText = Serializer + { getS = do + storeTextName <- getS storePathName + storeTextText <- getS text + pure StoreText{..} + , putS = \StoreText{..} -> do + putS storePathName storeTextName + putS text storeTextText + } + +workerOp :: NixSerializer r SError WorkerOp +workerOp = enum + +-- * Request + +data RequestSError + = RequestSError_NotYetImplemented WorkerOp + | RequestSError_ReservedOp WorkerOp + | RequestSError_PrimGet SError + | RequestSError_PrimPut SError + | RequestSError_PrimWorkerOp SError + deriving (Eq, Ord, Generic, Show) + +storeRequest + :: ( HasProtoVersion r + , HasStoreDir r + ) + => NixSerializer r RequestSError (Some StoreRequest) +storeRequest = Serializer + { getS = mapErrorST RequestSError_PrimWorkerOp (getS workerOp) >>= \case + WorkerOp_AddToStore -> mapGetE $ do + pathName <- getS storePathName + _fixed <- getS bool -- obsolete + recursive <- getS enum + hashAlgo <- getS someHashAlgo + + -- not supported by ProtoVersion < 1.25 + let repair = RepairMode_DontRepair + + pure $ Some (AddToStore pathName recursive hashAlgo repair) + + WorkerOp_AddTextToStore -> mapGetE $ do + txt <- getS storeText + paths <- getS (hashSet storePath) + let repair = RepairMode_DontRepair + pure $ Some (AddTextToStore txt paths repair) + + WorkerOp_AddSignatures -> mapGetE $ do + path <- getS storePath + signatures <- getS (set signature) + pure $ Some (AddSignatures path signatures) + + WorkerOp_AddIndirectRoot -> mapGetE $ do + Some . AddIndirectRoot <$> getS storePath + + WorkerOp_AddTempRoot -> mapGetE $ do + Some . AddTempRoot <$> getS storePath + + WorkerOp_BuildPaths -> mapGetE $ do + derived <- getS (set derivedPath) + buildMode' <- getS buildMode + pure $ Some (BuildPaths derived buildMode') + + WorkerOp_BuildDerivation -> mapGetE $ do + path <- getS storePath + drv <- getS derivation + buildMode' <- getS buildMode + pure $ Some (BuildDerivation path drv buildMode') + + WorkerOp_CollectGarbage -> mapGetE $ do + gcOptionsOperation <- getS enum + gcOptionsPathsToDelete <- getS (hashSet storePath) + gcOptionsIgnoreLiveness <- getS bool + gcOptionsMaxFreed <- getS int + -- obsolete fields + Control.Monad.forM_ [0..(2 :: Word8)] + $ pure $ getS (int @Word8) + pure $ Some (CollectGarbage GCOptions{..}) + + WorkerOp_EnsurePath -> mapGetE $ do + Some . EnsurePath <$> getS storePath + + WorkerOp_FindRoots -> mapGetE $ do + pure $ Some FindRoots + + WorkerOp_IsValidPath -> mapGetE $ do + Some . IsValidPath <$> getS storePath + + WorkerOp_QueryValidPaths -> mapGetE $ do + paths <- getS (hashSet storePath) + substituteMode <- getS enum + pure $ Some (QueryValidPaths paths substituteMode) + + WorkerOp_QueryAllValidPaths -> mapGetE $ do + pure $ Some QueryAllValidPaths + + WorkerOp_QuerySubstitutablePaths -> mapGetE $ do + Some . QuerySubstitutablePaths <$> getS (hashSet storePath) + + WorkerOp_QueryPathInfo -> mapGetE $ do + Some . QueryPathInfo <$> getS storePath + + WorkerOp_QueryReferrers -> mapGetE $ do + Some . QueryReferrers <$> getS storePath + + WorkerOp_QueryValidDerivers -> mapGetE $ do + Some . QueryValidDerivers <$> getS storePath + + WorkerOp_QueryDerivationOutputs -> mapGetE $ do + Some . QueryDerivationOutputs <$> getS storePath + + WorkerOp_QueryDerivationOutputNames -> mapGetE $ do + Some . QueryDerivationOutputNames <$> getS storePath + + WorkerOp_QueryPathFromHashPart -> mapGetE $ do + Some . QueryPathFromHashPart <$> getS storePathHashPart + + WorkerOp_QueryMissing -> mapGetE $ do + Some . QueryMissing <$> getS (set derivedPath) + + WorkerOp_OptimiseStore -> mapGetE $ do + pure $ Some OptimiseStore + + WorkerOp_SyncWithGC -> mapGetE $ do + pure $ Some SyncWithGC + + WorkerOp_VerifyStore -> mapGetE $ do + checkMode <- getS enum + repairMode <- getS enum + + pure $ Some (VerifyStore checkMode repairMode) + + w@WorkerOp_Reserved_0__ -> reserved w + w@WorkerOp_Reserved_2__ -> reserved w + w@WorkerOp_Reserved_15__ -> reserved w + w@WorkerOp_Reserved_17__ -> reserved w + + w@WorkerOp_AddBuildLog -> notYet w + w@WorkerOp_AddMultipleToStore -> notYet w + w@WorkerOp_AddToStoreNar -> notYet w + w@WorkerOp_BuildPathsWithResults -> notYet w + w@WorkerOp_ClearFailedPaths -> notYet w + w@WorkerOp_ExportPath -> notYet w + w@WorkerOp_HasSubstitutes -> notYet w + w@WorkerOp_ImportPaths -> notYet w + w@WorkerOp_NarFromPath -> notYet w + w@WorkerOp_QueryDerivationOutputMap -> notYet w + w@WorkerOp_QueryDeriver -> notYet w + w@WorkerOp_QueryFailedPaths -> notYet w + w@WorkerOp_QueryPathHash -> notYet w + w@WorkerOp_QueryRealisation -> notYet w + w@WorkerOp_QuerySubstitutablePathInfo -> notYet w + w@WorkerOp_QuerySubstitutablePathInfos -> notYet w + w@WorkerOp_QueryReferences -> notYet w + w@WorkerOp_RegisterDrvOutput -> notYet w + w@WorkerOp_SetOptions -> notYet w + + , putS = \case + Some (AddToStore pathName recursive hashAlgo _repair) -> mapPutE $ do + putS workerOp WorkerOp_AddToStore + + putS storePathName pathName + -- obsolete fixed + putS bool + $ not + $ hashAlgo == Some HashAlgo_SHA256 + && (recursive == FileIngestionMethod_FileRecursive) + + putS bool (recursive == FileIngestionMethod_FileRecursive) + putS someHashAlgo hashAlgo + + Some (AddTextToStore txt paths _repair) -> mapPutE $ do + putS workerOp WorkerOp_AddTextToStore + + putS storeText txt + putS (hashSet storePath) paths + + Some (AddSignatures path signatures) -> mapPutE $ do + putS workerOp WorkerOp_AddSignatures + + putS storePath path + putS (set signature) signatures + + Some (AddIndirectRoot path) -> mapPutE $ do + putS workerOp WorkerOp_AddIndirectRoot + putS storePath path + + Some (AddTempRoot path) -> mapPutE $ do + putS workerOp WorkerOp_AddTempRoot + putS storePath path + + Some (BuildPaths derived buildMode') -> mapPutE $ do + putS workerOp WorkerOp_BuildPaths + + putS (set derivedPath) derived + putS buildMode buildMode' + + Some (BuildDerivation path drv buildMode') -> mapPutE $ do + putS workerOp WorkerOp_BuildDerivation + + putS storePath path + putS derivation drv + putS buildMode buildMode' + + Some (CollectGarbage GCOptions{..}) -> mapPutE $ do + putS workerOp WorkerOp_CollectGarbage + + putS enum gcOptionsOperation + putS (hashSet storePath) gcOptionsPathsToDelete + putS bool gcOptionsIgnoreLiveness + putS int gcOptionsMaxFreed + -- obsolete fields + Control.Monad.forM_ [0..(2 :: Word8)] + $ pure $ putS int (0 :: Word8) + + Some (EnsurePath path) -> mapPutE $ do + putS workerOp WorkerOp_EnsurePath + putS storePath path + + Some FindRoots -> mapPutE $ do + putS workerOp WorkerOp_FindRoots + + Some (IsValidPath path) -> mapPutE $ do + putS workerOp WorkerOp_IsValidPath + putS storePath path + + Some (QueryValidPaths paths substituteMode) -> mapPutE $ do + putS workerOp WorkerOp_QueryValidPaths + + putS (hashSet storePath) paths + putS enum substituteMode + + Some QueryAllValidPaths -> mapPutE $ do + putS workerOp WorkerOp_QueryAllValidPaths + + Some (QuerySubstitutablePaths paths) -> mapPutE $ do + putS workerOp WorkerOp_QuerySubstitutablePaths + putS (hashSet storePath) paths + + Some (QueryPathInfo path) -> mapPutE $ do + putS workerOp WorkerOp_QueryPathInfo + putS storePath path + + Some (QueryReferrers path) -> mapPutE $ do + putS workerOp WorkerOp_QueryReferrers + putS storePath path + + Some (QueryValidDerivers path) -> mapPutE $ do + putS workerOp WorkerOp_QueryValidDerivers + putS storePath path + + Some (QueryDerivationOutputs path) -> mapPutE $ do + putS workerOp WorkerOp_QueryDerivationOutputs + putS storePath path + + Some (QueryDerivationOutputNames path) -> mapPutE $ do + putS workerOp WorkerOp_QueryDerivationOutputNames + putS storePath path + + Some (QueryPathFromHashPart pathHashPart) -> mapPutE $ do + putS workerOp WorkerOp_QueryPathFromHashPart + putS storePathHashPart pathHashPart + + Some (QueryMissing derived) -> mapPutE $ do + putS workerOp WorkerOp_QueryMissing + putS (set derivedPath) derived + + Some OptimiseStore -> mapPutE $ do + putS workerOp WorkerOp_OptimiseStore + + Some SyncWithGC -> mapPutE $ do + putS workerOp WorkerOp_SyncWithGC + + Some (VerifyStore checkMode repairMode) -> mapPutE $ do + putS workerOp WorkerOp_VerifyStore + putS enum checkMode + putS enum repairMode + } + where + mapGetE + :: Functor m + => SerialT r SError m a + -> SerialT r RequestSError m a + mapGetE = mapErrorST RequestSError_PrimGet + + mapPutE + :: Functor m + => SerialT r SError m a + -> SerialT r RequestSError m a + mapPutE = mapErrorST RequestSError_PrimPut + + notYet + :: MonadError RequestSError m + => WorkerOp + -> m a + notYet = throwError . RequestSError_NotYetImplemented + + reserved + :: MonadError RequestSError m + => WorkerOp + -> m a + reserved = throwError . RequestSError_ReservedOp + +-- ** Reply + +data ReplySError + = ReplySError_PrimGet SError + | ReplySError_PrimPut SError + | ReplySError_DerivationOutput SError + | ReplySError_GCResult SError + | ReplySError_Metadata SError + | ReplySError_Missing SError + | ReplySError_Realisation SError + | ReplySError_RealisationWithId SError + | ReplySError_UnexpectedFalseOpSuccess + deriving (Eq, Ord, Generic, Show) + +mapGetER + :: Functor m + => SerialT r SError m a + -> SerialT r ReplySError m a +mapGetER = mapErrorST ReplySError_PrimGet + +mapPutER + :: Functor m + => SerialT r SError m a + -> SerialT r ReplySError m a +mapPutER = mapErrorST ReplySError_PrimPut + +-- | Parse a bool returned at the end of simple operations. +-- This is always 1 (@True@) so we assert that it really is so. +-- Errors for these operations are indicated via @Logger_Error@. +opSuccess :: NixSerializer r ReplySError () +opSuccess = Serializer + { getS = do + retCode <- mapGetER $ getS bool + Control.Monad.unless + (retCode == True) + $ throwError ReplySError_UnexpectedFalseOpSuccess + pure () + , putS = \_ -> mapPutER $ putS bool True + } + +-- *** Realisation + +derivationOutputTyped :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName) +derivationOutputTyped = mapErrorS ReplySError_DerivationOutput $ + mapPrismSerializer + ( Data.Bifunctor.first SError_DerivationOutput + . System.Nix.Realisation.derivationOutputParser + System.Nix.OutputName.mkOutputName + ) + ( Data.Text.Lazy.toStrict + . Data.Text.Lazy.Builder.toLazyText + . System.Nix.Realisation.derivationOutputBuilder + System.Nix.OutputName.unOutputName + ) + text + +realisation :: NixSerializer r ReplySError Realisation +realisation = mapErrorS ReplySError_Realisation json + +realisationWithId :: NixSerializer r ReplySError (System.Nix.Realisation.DerivationOutput OutputName, Realisation) +realisationWithId = mapErrorS ReplySError_RealisationWithId json + +-- *** BuildResult + +buildResult + :: ( HasProtoVersion r + , HasStoreDir r + ) + => NixSerializer r ReplySError BuildResult +buildResult = Serializer + { getS = do + pv <- Control.Monad.Reader.asks hasProtoVersion + + buildResultStatus <- mapGetER $ getS enum + buildResultErrorMessage <- mapGetER $ getS maybeText + + ( buildResultTimesBuilt + , buildResultIsNonDeterministic + , buildResultStartTime + , buildResultStopTime + ) <- + if protoVersion_minor pv >= 29 + then mapGetER $ do + tb <- (\case 0 -> Nothing; x -> Just x) <$> getS int + nondet <- getS bool + start <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time + end <- (\case x | x == t0 -> Nothing; x -> Just x) <$> getS time + pure $ (tb, pure nondet, start, end) + else pure $ (Nothing, Nothing, Nothing, Nothing) + + buildResultBuiltOutputs <- + if protoVersion_minor pv >= 28 + then + pure + . Data.Map.Strict.fromList + . map (\(_, (a, b)) -> (a, b)) + . Data.Map.Strict.toList + <$> getS (mapS derivationOutputTyped realisationWithId) + else pure Nothing + pure BuildResult{..} + + , putS = \BuildResult{..} -> do + pv <- Control.Monad.Reader.asks hasProtoVersion + + mapPutER $ putS enum buildResultStatus + mapPutER $ putS maybeText buildResultErrorMessage + Control.Monad.when (protoVersion_minor pv >= 29) $ mapPutER $ do + putS int $ Data.Maybe.fromMaybe 0 buildResultTimesBuilt + putS bool $ Data.Maybe.fromMaybe False buildResultIsNonDeterministic + putS time $ Data.Maybe.fromMaybe t0 buildResultStartTime + putS time $ Data.Maybe.fromMaybe t0 buildResultStopTime + Control.Monad.when (protoVersion_minor pv >= 28) + $ putS (mapS derivationOutputTyped realisationWithId) + $ Data.Map.Strict.fromList + $ map (\(a, b) -> (a, (a, b))) + $ Data.Map.Strict.toList + $ Data.Maybe.fromMaybe mempty buildResultBuiltOutputs + } + where + t0 :: UTCTime + t0 = Data.Time.Clock.POSIX.posixSecondsToUTCTime 0 + +-- *** GCResult + +gcResult + :: HasStoreDir r + => NixSerializer r ReplySError GCResult +gcResult = mapErrorS ReplySError_GCResult $ Serializer + { getS = do + gcResultDeletedPaths <- getS (hashSet storePath) + gcResultBytesFreed <- getS int + Control.Monad.void $ getS (int @Word64) -- obsolete + pure GCResult{..} + , putS = \GCResult{..} -> do + putS (hashSet storePath) gcResultDeletedPaths + putS int gcResultBytesFreed + putS (int @Word64) 0 -- obsolete + } + +-- *** GCRoot + +gcRoot :: NixSerializer r ReplySError GCRoot +gcRoot = Serializer + { getS = mapGetER $ do + getS byteString >>= \case + p | p == censored -> pure GCRoot_Censored + p -> pure (GCRoot_Path p) + , putS = mapPutER . putS byteString . \case + GCRoot_Censored -> censored + GCRoot_Path p -> p + } + where censored = Data.ByteString.Char8.pack "{censored}" + +-- *** Missing + +missing + :: HasStoreDir r + => NixSerializer r ReplySError Missing +missing = mapErrorS ReplySError_Missing $ Serializer + { getS = do + missingWillBuild <- getS (hashSet storePath) + missingWillSubstitute <- getS (hashSet storePath) + missingUnknownPaths <- getS (hashSet storePath) + missingDownloadSize <- getS int + missingNarSize <- getS int + + pure Missing{..} + , putS = \Missing{..} -> do + putS (hashSet storePath) missingWillBuild + putS (hashSet storePath) missingWillSubstitute + putS (hashSet storePath) missingUnknownPaths + putS int missingDownloadSize + putS int missingNarSize + } + +-- *** Maybe (Metadata StorePath) + +maybePathMetadata + :: HasStoreDir r + => NixSerializer r ReplySError (Maybe (Metadata StorePath)) +maybePathMetadata = mapErrorS ReplySError_Metadata $ Serializer + { getS = do + valid <- getS bool + if valid + then pure <$> getS pathMetadata + else pure Nothing + , putS = \case + Nothing -> putS bool False + Just pm -> putS bool True >> putS pathMetadata pm + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs new file mode 100644 index 00000000..41cd4739 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Server.hs @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs index 9ef0435e..ac76f809 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs @@ -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 + + Right result | Data.ByteString.length result == 0 -> + throwError RemoteStoreError_Disconnected -sockPut :: Put -> MonadStore () + 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 - -sockGet :: Get a -> MonadStore a -sockGet = getSocketIncremental + r <- ask + case runP s r a of + Right x -> liftIO $ sendAll (hasStoreSocket r) x + Left e -> throwError e -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 +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 -sockGetPaths :: MonadStore (HashSet StorePath) -sockGetPaths = do - sd <- getStoreDir - getSocketIncremental (getPathsOrFail sd) + case res of + Right x -> pure x + Left e -> throwError e diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs index f37f122e..8c23f965 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs index 0eb5e9d6..dd3c0020 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/GC.hs @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs new file mode 100644 index 00000000..3f3fa90d --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Handshake.hs @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs index 779909cb..543b94c7 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Logger.hs @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs index f783671e..766a83fd 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/ProtoVersion.hs @@ -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 + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query.hs new file mode 100644 index 00000000..82ef2384 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query/Missing.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query/Missing.hs new file mode 100644 index 00000000..534bd0fb --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/Query/Missing.hs @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs index e482393b..4735fa8e 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreConfig.hs @@ -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 + } diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs new file mode 100644 index 00000000..c6a475d9 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreReply.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs new file mode 100644 index 00000000..a3752940 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreRequest.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreText.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreText.hs new file mode 100644 index 00000000..1814edfc --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/StoreText.hs @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/TrustedFlag.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/TrustedFlag.hs new file mode 100644 index 00000000..9e51b575 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/TrustedFlag.hs @@ -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) diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerMagic.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerMagic.hs new file mode 100644 index 00000000..f8878266 --- /dev/null +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerMagic.hs @@ -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 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs index 6fd18f9e..1839fad4 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Types/WorkerOp.hs @@ -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) diff --git a/hnix-store-remote/tests-io/Driver.hs b/hnix-store-remote/tests-io/Driver.hs deleted file mode 100644 index a5dabaf6..00000000 --- a/hnix-store-remote/tests-io/Driver.hs +++ /dev/null @@ -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 diff --git a/hnix-store-remote/tests-io/Main.hs b/hnix-store-remote/tests-io/Main.hs new file mode 100644 index 00000000..41032de9 --- /dev/null +++ b/hnix-store-remote/tests-io/Main.hs @@ -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 diff --git a/hnix-store-remote/tests-io/NixDaemon.hs b/hnix-store-remote/tests-io/NixDaemon.hs deleted file mode 100644 index b7f34120..00000000 --- a/hnix-store-remote/tests-io/NixDaemon.hs +++ /dev/null @@ -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 /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 - diff --git a/hnix-store-remote/tests-io/NixDaemonSpec.hs b/hnix-store-remote/tests-io/NixDaemonSpec.hs new file mode 100644 index 00000000..3e8aec1e --- /dev/null +++ b/hnix-store-remote/tests-io/NixDaemonSpec.hs @@ -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 /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 diff --git a/hnix-store-remote/tests-io/Spec.hs b/hnix-store-remote/tests-io/Spec.hs deleted file mode 100644 index 203ed407..00000000 --- a/hnix-store-remote/tests-io/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Spec #-} diff --git a/hnix-store-remote/tests/EnumSpec.hs b/hnix-store-remote/tests/EnumSpec.hs new file mode 100644 index 00000000..1c28c1ca --- /dev/null +++ b/hnix-store-remote/tests/EnumSpec.hs @@ -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 + + + diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 9356bf28..0fa21155 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -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 diff --git a/hnix-store-remote/tests/SerializeSpec.hs b/hnix-store-remote/tests/SerializeSpec.hs deleted file mode 100644 index 4b9c1d43..00000000 --- a/hnix-store-remote/tests/SerializeSpec.hs +++ /dev/null @@ -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 diff --git a/hnix-store-tests/hnix-store-tests.cabal b/hnix-store-tests/hnix-store-tests.cabal index e975c981..e79dd67b 100644 --- a/hnix-store-tests/hnix-store-tests.cabal +++ b/hnix-store-tests/hnix-store-tests.cabal @@ -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 diff --git a/hnix-store-tests/src/Data/ByteString/Arbitrary.hs b/hnix-store-tests/src/Data/ByteString/Arbitrary.hs new file mode 100644 index 00000000..00248002 --- /dev/null +++ b/hnix-store-tests/src/Data/ByteString/Arbitrary.hs @@ -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) diff --git a/hnix-store-tests/src/Data/HashSet/Arbitrary.hs b/hnix-store-tests/src/Data/HashSet/Arbitrary.hs new file mode 100644 index 00000000..a992a5a4 --- /dev/null +++ b/hnix-store-tests/src/Data/HashSet/Arbitrary.hs @@ -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) diff --git a/hnix-store-tests/src/Data/Text/Arbitrary.hs b/hnix-store-tests/src/Data/Text/Arbitrary.hs new file mode 100644 index 00000000..34cba8e9 --- /dev/null +++ b/hnix-store-tests/src/Data/Text/Arbitrary.hs @@ -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)) + ] diff --git a/hnix-store-tests/src/Data/Vector/Arbitrary.hs b/hnix-store-tests/src/Data/Vector/Arbitrary.hs new file mode 100644 index 00000000..0d006dc7 --- /dev/null +++ b/hnix-store-tests/src/Data/Vector/Arbitrary.hs @@ -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 diff --git a/hnix-store-tests/src/System/Nix/Arbitrary.hs b/hnix-store-tests/src/System/Nix/Arbitrary.hs index 4d2f5b55..ff114d77 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary.hs @@ -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 () diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Base.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Base.hs index 0f89ad2f..0a24e074 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Base.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Base.hs @@ -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 diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs index 3052ec9e..3cd24296 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Build.hs @@ -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 diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs index 4d9b567b..9910dee9 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs @@ -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) diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs b/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs index 7ea79558..1a3c56dc 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/DerivedPath.hs @@ -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 diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs index b959d337..ad9b3086 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs @@ -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 diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs b/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs new file mode 100644 index 00000000..0ef7ba21 --- /dev/null +++ b/hnix-store-tests/src/System/Nix/Arbitrary/OutputName.hs @@ -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 diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs new file mode 100644 index 00000000..509b26af --- /dev/null +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Realisation.hs @@ -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 diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs index 17520c3c..b11f9ae7 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Signature.hs @@ -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 diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs index 9b75621b..c07c9b39 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath.hs @@ -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 = diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs index 8ce25f02..8cd26b67 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/StorePath/Metadata.hs @@ -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{..} diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/UTCTime.hs b/hnix-store-tests/src/System/Nix/Arbitrary/UTCTime.hs new file mode 100644 index 00000000..8eb33376 --- /dev/null +++ b/hnix-store-tests/src/System/Nix/Arbitrary/UTCTime.hs @@ -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 ] + diff --git a/hnix-store-tests/src/Test/Hspec/Nix.hs b/hnix-store-tests/src/Test/Hspec/Nix.hs index 01416d98..814ca8fb 100644 --- a/hnix-store-tests/src/Test/Hspec/Nix.hs +++ b/hnix-store-tests/src/Test/Hspec/Nix.hs @@ -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 diff --git a/hnix-store-tests/tests/DerivedPathSpec.hs b/hnix-store-tests/tests/DerivedPathSpec.hs index f2a0b62a..7debac2e 100644 --- a/hnix-store-tests/tests/DerivedPathSpec.hs +++ b/hnix-store-tests/tests/DerivedPathSpec.hs @@ -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) diff --git a/hnix-store-tests/tests/RealisationSpec.hs b/hnix-store-tests/tests/RealisationSpec.hs new file mode 100644 index 00000000..022b5402 --- /dev/null +++ b/hnix-store-tests/tests/RealisationSpec.hs @@ -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 + ) diff --git a/hnix-store-tests/tests/SignatureSpec.hs b/hnix-store-tests/tests/SignatureSpec.hs index 3814e5b9..e7f6dd6b 100644 --- a/hnix-store-tests/tests/SignatureSpec.hs +++ b/hnix-store-tests/tests/SignatureSpec.hs @@ -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 diff --git a/overlay.nix b/overlay.nix index a0d25588..0c2b4607 100644 --- a/overlay.nix +++ b/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 {}) diff --git a/shell.nix b/shell.nix index 72ff0287..4dd2baf0 100644 --- a/shell.nix +++ b/shell.nix @@ -6,6 +6,7 @@ let packages = [ "hnix-store-core" "hnix-store-db" + "hnix-store-json" "hnix-store-nar" "hnix-store-readonly" "hnix-store-remote"