diff --git a/hnix-store-aterm/bench/Main.hs b/hnix-store-aterm/bench/Main.hs index 30cdf87c..dae3e228 100644 --- a/hnix-store-aterm/bench/Main.hs +++ b/hnix-store-aterm/bench/Main.hs @@ -22,10 +22,7 @@ benchmarks = bench0 example = Criterion.bench "example" (Criterion.nf parseExample example) - name = either (error . show) id $ mkStorePathName "ghc-8.0.2-with-packages" - parseExample = Data.Attoparsec.Text.Lazy.parse $ - System.Nix.Derivation.ATerm.parseDerivation + System.Nix.Derivation.ATerm.parseTraditionalDerivation (StoreDir "/nix/store") - name diff --git a/hnix-store-aterm/hnix-store-aterm.cabal b/hnix-store-aterm/hnix-store-aterm.cabal index 78a5c137..38bd8921 100644 --- a/hnix-store-aterm/hnix-store-aterm.cabal +++ b/hnix-store-aterm/hnix-store-aterm.cabal @@ -96,6 +96,7 @@ Test-Suite property hnix-store-core , hnix-store-aterm , hnix-store-tests , + containers , generic-arbitrary < 1.1 , QuickCheck < 2.16, text , diff --git a/hnix-store-aterm/pretty-derivation/Main.hs b/hnix-store-aterm/pretty-derivation/Main.hs index f1f7b1a4..259b3489 100644 --- a/hnix-store-aterm/pretty-derivation/Main.hs +++ b/hnix-store-aterm/pretty-derivation/Main.hs @@ -14,9 +14,8 @@ main = do text <- Data.Text.Lazy.IO.getContents case Data.Attoparsec.Text.Lazy.parse - (System.Nix.Derivation.ATerm.parseDerivation - (StoreDir "/nix/store") - (error "todo get name from outputs if needed")) + (System.Nix.Derivation.ATerm.parseTraditionalDerivation + (StoreDir "/nix/store")) text of Fail _ _ err -> fail err diff --git a/hnix-store-aterm/src/System/Nix/Derivation/ATerm.hs b/hnix-store-aterm/src/System/Nix/Derivation/ATerm.hs index 907b6300..d8e7075e 100644 --- a/hnix-store-aterm/src/System/Nix/Derivation/ATerm.hs +++ b/hnix-store-aterm/src/System/Nix/Derivation/ATerm.hs @@ -78,26 +78,27 @@ module System.Nix.Derivation.ATerm ( -- * Types - Derivation - , Derivation'(..) - , DerivationOutput(..) - , DerivationInputs(..) + TraditionalDerivation'(..) + , FreeformDerivationOutput(..) + , FreeformDerivationOutputs + , TraditionalDerivationInputs(..) , DerivedPathMap(..) -- * Parse derivations - , parseDerivation - , parseDerivationWith - , parseDerivationOutput - , parseDerivationInputs + , parseTraditionalDerivation + , parseTraditionalDerivationWith + , parseFreeformDerivationOutput + , parseTraditionalDerivationInputs , textParser -- * Render derivations - , buildDerivation - , buildDerivationWith - , buildDerivationOutput - , buildDerivationInputs + , buildTraditionalDerivation + , buildTraditionalDerivationWith + , buildFreeformDerivationOutput + , buildTraditionalDerivationInputs ) where import System.Nix.Derivation +import System.Nix.Derivation.Traditional import System.Nix.Derivation.ATerm.Builder import System.Nix.Derivation.ATerm.Parser diff --git a/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Builder.hs b/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Builder.hs index bc66c204..8849a91f 100644 --- a/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Builder.hs +++ b/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Builder.hs @@ -6,10 +6,10 @@ module System.Nix.Derivation.ATerm.Builder ( -- * Builder - buildDerivation - , buildDerivationWith - , buildDerivationOutput - , buildDerivationInputs + buildTraditionalDerivation + , buildTraditionalDerivationWith + , buildFreeformDerivationOutput + , buildTraditionalDerivationInputs ) where import Data.Map (Map) @@ -18,8 +18,8 @@ import Data.Text (Text) import Data.Text.Lazy.Builder (Builder) import Data.Vector (Vector) import System.Nix.Derivation - ( Derivation'(..) - , DerivationOutput(..) + ( FreeformDerivationOutput(..) + , FreeformDerivationOutputs ) import System.Nix.Derivation.Traditional import System.Nix.StorePath @@ -32,42 +32,42 @@ import Data.Text.Lazy.Builder qualified import Data.Vector qualified -- | Render a derivation as a `Builder` -buildDerivation +buildTraditionalDerivation :: StoreDir - -> Derivation' TraditionalDerivationInputs DerivationOutput + -> TraditionalDerivation' TraditionalDerivationInputs FreeformDerivationOutputs -> Builder -buildDerivation sd = - buildDerivationWith - (buildDerivationInputs sd) - (buildDerivationOutput sd) +buildTraditionalDerivation sd = + buildTraditionalDerivationWith + (buildTraditionalDerivationInputs sd) + (\_ -> buildFreeformDerivationOutput sd) -- | Render a derivation as a `Builder` using custom -- renderer for storePaths, texts, outputNames and derivation inputs/outputs -buildDerivationWith +buildTraditionalDerivationWith :: (drvInputs -> Builder) - -> (StorePathName -> OutputName -> drvOutput -> Builder) - -> Derivation' drvInputs drvOutput + -> (OutputName -> drvOutput -> Builder) + -> TraditionalDerivation' drvInputs (Map OutputName drvOutput) -> Builder -buildDerivationWith drvInputs drvOutput (Derivation {..}) = +buildTraditionalDerivationWith drvInputs drvOutput (TraditionalDerivation {..}) = "Derive(" - <> mapOf keyValue0 outputs + <> mapOf keyValue0 anonOutputs <> "," - <> drvInputs inputs + <> drvInputs anonInputs <> "," - <> string platform + <> string anonPlatform <> "," - <> string builder + <> string anonBuilder <> "," - <> vectorOf string args + <> vectorOf string anonArgs <> "," - <> mapOf keyValue1 env + <> mapOf keyValue1 anonEnv <> ")" where keyValue0 (key, output) = "(" <> buildOutputName key <> "," - <> drvOutput name key output + <> drvOutput key output <> ")" keyValue1 (key, value) = @@ -77,15 +77,13 @@ buildDerivationWith drvInputs drvOutput (Derivation {..}) = <> string value <> ")" --- | Render a @DerivationOutput@ as a `Builder` using custom +-- | Render a @FreeformDerivationOutput@ as a `Builder` using custom -- renderer for storePaths -buildDerivationOutput +buildFreeformDerivationOutput :: StoreDir - -> StorePathName - -> OutputName - -> DerivationOutput + -> FreeformDerivationOutput -> Builder -buildDerivationOutput storeDir drvName outputName = +buildFreeformDerivationOutput storeDir = ( \RawDerivationOutput {..} -> string rawPath <> "," @@ -93,15 +91,15 @@ buildDerivationOutput storeDir drvName outputName = <> "," <> string rawHash ) - . renderRawDerivationOutput storeDir drvName outputName + . renderRawDerivationOutput storeDir --- | Render a @DerivationInputs@ as a `Builder` using custom +-- | Render a @TraditionalDerivationInputs@ as a `Builder` using custom -- renderer for storePaths and output names -buildDerivationInputs +buildTraditionalDerivationInputs :: StoreDir -> TraditionalDerivationInputs -> Builder -buildDerivationInputs storeDir (TraditionalDerivationInputs {..}) = +buildTraditionalDerivationInputs storeDir (TraditionalDerivationInputs {..}) = mapOf keyValue traditionalDrvs <> "," <> setOf (storePath storeDir) traditionalSrcs diff --git a/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Parser.hs b/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Parser.hs index 5813eccf..b7ba9af5 100644 --- a/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Parser.hs +++ b/hnix-store-aterm/src/System/Nix/Derivation/ATerm/Parser.hs @@ -9,10 +9,10 @@ module System.Nix.Derivation.ATerm.Parser ( -- * Parser - parseDerivation - , parseDerivationWith - , parseDerivationOutput - , parseDerivationInputs + parseTraditionalDerivation + , parseTraditionalDerivationWith + , parseFreeformDerivationOutput + , parseTraditionalDerivationInputs , textParser ) where @@ -28,11 +28,11 @@ import Data.Text qualified import Data.Vector (Vector) import Data.Vector qualified -import System.Nix.Derivation.Traditional import System.Nix.Derivation - ( Derivation'(..) - , DerivationOutput(..) + ( FreeformDerivationOutput(..) + , FreeformDerivationOutputs ) +import System.Nix.Derivation.Traditional import System.Nix.StorePath import System.Nix.OutputName @@ -44,46 +44,47 @@ listOf element = do pure es -- | Parse a derivation -parseDerivation :: StoreDir -> StorePathName -> Parser (Derivation' TraditionalDerivationInputs DerivationOutput) -parseDerivation sd = - parseDerivationWith - (parseDerivationInputs sd) - (parseDerivationOutput sd) +parseTraditionalDerivation + :: StoreDir + -> Parser (TraditionalDerivation' TraditionalDerivationInputs FreeformDerivationOutputs) +parseTraditionalDerivation sd = + parseTraditionalDerivationWith + (parseTraditionalDerivationInputs sd) + (\_ -> parseFreeformDerivationOutput sd) -- | Parse a derivation using custom -- parsers for filepaths, texts, outputNames and derivation inputs/outputs -parseDerivationWith +parseTraditionalDerivationWith :: Parser drvInputs - -> (StorePathName -> OutputName -> Parser drvOutput) - -> StorePathName - -> Parser (Derivation' drvInputs drvOutput) -parseDerivationWith parseInputs parseOutput name = do + -> (OutputName -> Parser drvOutput) + -> Parser (TraditionalDerivation' drvInputs (Map OutputName drvOutput)) +parseTraditionalDerivationWith parseInputs parseOutput = do "Derive(" let keyValue0 = do "(" key <- outputNameParser "," - drvOutput <- parseOutput name key + drvOutput <- parseOutput key ")" return (key, drvOutput) - outputs <- mapOf keyValue0 + anonOutputs <- mapOf keyValue0 "," - inputs <- parseInputs + anonInputs <- parseInputs "," - platform <- textParser + anonPlatform <- textParser "," - builder <- textParser + anonBuilder <- textParser "," - args <- vectorOf textParser + anonArgs <- vectorOf textParser "," @@ -94,25 +95,25 @@ parseDerivationWith parseInputs parseOutput name = do value <- textParser ")" pure (key, value) - env <- mapOf keyValue1 + anonEnv <- mapOf keyValue1 ")" - pure Derivation {..} + pure TraditionalDerivation {..} -- | Parse a derivation output -parseDerivationOutput :: StoreDir -> StorePathName -> OutputName -> Parser DerivationOutput -parseDerivationOutput sd drvName outputName = do +parseFreeformDerivationOutput :: StoreDir -> Parser FreeformDerivationOutput +parseFreeformDerivationOutput sd = do rawPath <- textParser "," rawMethodHashAlgo <- textParser "," rawHash <- textParser - parseRawDerivationOutput sd drvName outputName $ RawDerivationOutput {..} + parseRawDerivationOutput sd $ RawDerivationOutput {..} -- | Parse a derivation inputs -parseDerivationInputs :: StoreDir -> Parser TraditionalDerivationInputs -parseDerivationInputs sd = do +parseTraditionalDerivationInputs :: StoreDir -> Parser TraditionalDerivationInputs +parseTraditionalDerivationInputs sd = do traditionalDrvs <- mapOf $ do "(" key <- storePathParser sd diff --git a/hnix-store-aterm/src/System/Nix/Derivation/Traditional.hs b/hnix-store-aterm/src/System/Nix/Derivation/Traditional.hs index 8367371d..f36a3383 100644 --- a/hnix-store-aterm/src/System/Nix/Derivation/Traditional.hs +++ b/hnix-store-aterm/src/System/Nix/Derivation/Traditional.hs @@ -4,6 +4,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,31 +16,37 @@ module System.Nix.Derivation.Traditional ( RawDerivationOutput(..) , parseRawDerivationOutput , renderRawDerivationOutput + , TraditionalDerivation'(..) + , withName + , withoutName , TraditionalDerivationInputs(..) , inputsToTraditional + , inputsFromTraditional ) where -import Control.Monad (when) import Control.DeepSeq (NFData(..)) import Data.Constraint.Extras (Has(has)) import Data.Dependent.Sum (DSum(..)) import Data.Map (Map) +import Data.Map qualified import Data.Map.Monoidal (MonoidalMap(..)) import Data.Map.Monoidal qualified +import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Some import Data.Text (Text) import Data.Text qualified import Data.These (These(..)) -import GHC.Generics (Generic) +import Data.Vector (Vector) +import Data.Traversable (for) +import GHC.Generics (Generic, (:.:)(..)) import System.Nix.ContentAddress (ContentAddressMethod(..)) import System.Nix.Derivation import System.Nix.Hash -import System.Nix.OutputName (OutputName, outputStoreObjectName) +import System.Nix.OutputName (OutputName) import System.Nix.StorePath -import System.Nix.StorePath.ContentAddressed -- | Useful for the ATerm format, and remote protocols that need the same parsing -- If it won't for the protocol, we would just inline this into the ATerm code proper. @@ -53,63 +60,41 @@ parseRawDerivationOutput :: forall m . MonadFail m => StoreDir - -> StorePathName - -> OutputName -> RawDerivationOutput - -> m DerivationOutput -parseRawDerivationOutput storeDir drvName outputName (RawDerivationOutput {..}) = do - let onNonEmptyText :: Text -> (Text -> m a) -> m (Maybe a) - onNonEmptyText = flip $ \f -> \case - "" -> pure Nothing - t -> Just <$> f t - mPath <- onNonEmptyText rawPath $ \t -> case System.Nix.StorePath.parsePathFromText storeDir t of - Left e -> fail $ show e -- TODO - Right sp -> pure sp - mHashAlgo <- onNonEmptyText rawMethodHashAlgo splitMethodHashAlgo - mHash <- onNonEmptyText rawHash pure - case (mPath, mHashAlgo, mHash) of - (Just path, Nothing, Nothing) -> - pure InputAddressedDerivationOutput {..} - (Just path, Just (method, Some hashAlgo), Just hash0) -> do - hash' <- either fail pure $ has @NamedAlgo hashAlgo $ - decodeDigestWith NixBase32 hash0 - let hash = hashAlgo :=> hash' - fullOutputName <- either (fail . show) pure $ - outputStoreObjectName drvName outputName - let expectedPath = makeFixedOutputPath storeDir method hash mempty fullOutputName - when (path /= expectedPath) $ - fail "fixed output path does not match info" - pure FixedDerivationOutput {..} - (Nothing, Just (method, hashAlgo), Nothing) -> do - pure ContentAddressedDerivationOutput {..} - _ -> - fail "bad output in derivation" + -> m FreeformDerivationOutput +parseRawDerivationOutput storeDir (RawDerivationOutput {..}) = do + let onNonEmptyText :: Text -> (Text -> m a) -> m (Maybe a) + onNonEmptyText = flip $ \f -> \case + "" -> pure Nothing + t -> Just <$> f t + mPath <- onNonEmptyText rawPath $ \t -> case System.Nix.StorePath.parsePathFromText storeDir t of + Left e -> fail $ show e -- TODO + Right sp -> pure sp + mMethodHashAlgo <- onNonEmptyText rawMethodHashAlgo splitMethodHashAlgo + mHash0 <- onNonEmptyText rawHash pure + mContentAddressing <- case mMethodHashAlgo of + Nothing -> case mHash0 of + Nothing -> pure Nothing + Just _ -> fail "Hash without method and hash algo is not allowed" + Just (method, Some hashAlgo) -> do + mHash <- for mHash0 $ \hash0 -> + either fail pure $ has @NamedAlgo hashAlgo $ + decodeDigestWith NixBase32 hash0 + pure $ Just (method, hashAlgo :=> Comp1 mHash) + pure FreeformDerivationOutput { mPath, mContentAddressing } renderRawDerivationOutput :: StoreDir - -> StorePathName - -> OutputName - -> DerivationOutput + -> FreeformDerivationOutput -> RawDerivationOutput -renderRawDerivationOutput storeDir drvName outputName = \case - InputAddressedDerivationOutput {..} -> RawDerivationOutput - { rawPath = storePathToText storeDir path - , rawMethodHashAlgo = "" - , rawHash = "" +renderRawDerivationOutput storeDir (FreeformDerivationOutput {..}) = + RawDerivationOutput + { rawPath = fromMaybe "" $ storePathToText storeDir <$> mPath + , rawMethodHashAlgo = flip (maybe "") mContentAddressing $ \(method, hashAlgo :=> _) -> + buildMethodHashAlgo method $ Some hashAlgo + , rawHash = fromMaybe "" $ mContentAddressing >>= \(_, _ :=> Comp1 hash') -> + encodeDigestWith NixBase32 <$> hash' } - FixedDerivationOutput {..} -> case hash of - hashAlgo :=> hash' -> RawDerivationOutput - { rawPath = storePathToText storeDir $ makeFixedOutputPath storeDir method hash mempty - $ either (error . show) id -- TODO do better - $ outputStoreObjectName drvName outputName - , rawMethodHashAlgo = buildMethodHashAlgo method $ Some hashAlgo - , rawHash = encodeDigestWith NixBase32 hash' - } - ContentAddressedDerivationOutput {..} -> RawDerivationOutput - { rawPath = "" - , rawMethodHashAlgo = buildMethodHashAlgo method hashAlgo - , rawHash = "" - } buildMethodHashAlgo :: ContentAddressMethod -> Some HashAlgo -> Text buildMethodHashAlgo method hashAlgo = Data.Text.intercalate ":" $ @@ -130,6 +115,51 @@ splitMethodHashAlgo methodHashAlgo = do hashAlgo <- either fail pure $ textToAlgo hashAlgoS pure (method, hashAlgo) +---------------- + +-- | The ATerm format doesn't include the derivation name. That must +-- instead be gotten out of band, e.g. from the Store Path. +data TraditionalDerivation' inputs outputs = TraditionalDerivation + { anonOutputs :: outputs + -- ^ Outputs produced by this derivation where keys are output names + , anonInputs :: inputs + -- ^ Inputs (sources and derivations) + , anonPlatform :: Text + -- ^ Platform required for this derivation + , anonBuilder :: Text + -- ^ Code to build the derivation, which can be a path or a builtin function + , anonArgs :: Vector Text + -- ^ Arguments passed to the executable used to build to derivation + , anonEnv :: Map Text Text + -- ^ Environment variables provided to the executable used to build the + -- derivation + } deriving (Eq, Generic, Ord, Show) + +instance (NFData inputs, NFData outputs) => NFData (TraditionalDerivation' inputs outputs) + +withName :: StorePathName -> TraditionalDerivation' inputs outputs -> Derivation' inputs outputs +withName name drv0 = Derivation + { name = name + , outputs = anonOutputs drv0 + , inputs = anonInputs drv0 + , platform = anonPlatform drv0 + , builder = anonBuilder drv0 + , args = anonArgs drv0 + , env = anonEnv drv0 + } + +withoutName :: Derivation' inputs outputs -> TraditionalDerivation' inputs outputs +withoutName drv0 = TraditionalDerivation + { anonOutputs = outputs drv0 + , anonPlatform = platform drv0 + , anonInputs = inputs drv0 + , anonBuilder = builder drv0 + , anonArgs = args drv0 + , anonEnv = env drv0 + } + +---------------- + -- | Useful for the ATerm format data TraditionalDerivationInputs = TraditionalDerivationInputs { traditionalSrcs :: Set StorePath @@ -162,3 +192,10 @@ inputsToTraditional is = (\drvs -> TraditionalDerivationInputs _ -> Left storePath -- TODO make better error, e.g. by partitioning the map ) . unChildNode) . unDerivedPathMap + +inputsFromTraditional :: TraditionalDerivationInputs -> DerivationInputs +inputsFromTraditional TraditionalDerivationInputs { traditionalSrcs, traditionalDrvs } = DerivationInputs + { srcs = traditionalSrcs + , drvs = DerivedPathMap $ Data.Map.Monoidal.fromList $ + fmap (fmap ChildNode . fmap This) (Data.Map.toList traditionalDrvs) + } diff --git a/hnix-store-aterm/tests/Example.hs b/hnix-store-aterm/tests/Example.hs index 707ab293..59fb4ac0 100644 --- a/hnix-store-aterm/tests/Example.hs +++ b/hnix-store-aterm/tests/Example.hs @@ -11,18 +11,17 @@ import System.Nix.Derivation.ATerm qualified main :: IO () main = do - name <- either (fail . show) pure $ mkStorePathName "perl-MIME-Types-2.13-devdoc" let storeDir = StoreDir "/nix/store" text0 <- Data.Text.Lazy.IO.readFile "tests/example0.drv" derivation <- case Data.Attoparsec.Text.Lazy.parse - (System.Nix.Derivation.ATerm.parseDerivation storeDir name) + (System.Nix.Derivation.ATerm.parseTraditionalDerivation storeDir) text0 of Fail _ _ string -> fail string Done _ derivation -> return derivation - let builder = System.Nix.Derivation.ATerm.buildDerivation storeDir derivation + let builder = System.Nix.Derivation.ATerm.buildTraditionalDerivation storeDir derivation let text1 = Data.Text.Lazy.Builder.toLazyText builder if text0 == text1 then return () diff --git a/hnix-store-aterm/tests/Property.hs b/hnix-store-aterm/tests/Property.hs index 87e6f2ca..f0727253 100644 --- a/hnix-store-aterm/tests/Property.hs +++ b/hnix-store-aterm/tests/Property.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} -- due to recent generic-arbitrary {-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -14,44 +15,49 @@ import Prelude hiding (FilePath, either) import Data.Attoparsec.Text.Lazy qualified import Data.Text.Lazy.Builder qualified -import Test.QuickCheck (Arbitrary(..)) +import Test.QuickCheck (Arbitrary) import Test.QuickCheck qualified import Test.QuickCheck.Property (failed, succeeded, Result(..)) -import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..)) +import Test.QuickCheck.Arbitrary.Generic (Arg, GenericArbitrary(..)) import System.Nix.StorePath -import System.Nix.Derivation - ( Derivation'(..) - , DerivationOutput(..) - ) import System.Nix.Arbitrary.Derivation () +import System.Nix.Derivation import System.Nix.Derivation.ATerm qualified import System.Nix.Derivation.Traditional deriving via GenericArbitrary TraditionalDerivationInputs instance Arbitrary TraditionalDerivationInputs +deriving via GenericArbitrary (TraditionalDerivation' inputs outputs) + instance + ( Arbitrary inputs + , Arbitrary outputs + , Arg (TraditionalDerivation' inputs outputs) inputs + , Arg (TraditionalDerivation' inputs outputs) outputs + ) => Arbitrary (TraditionalDerivation' inputs outputs) + property :: StoreDir - -> Derivation' + -> TraditionalDerivation' TraditionalDerivationInputs - DerivationOutput + FreeformDerivationOutputs -> Result property storeDir derivation0 = if either == expected then succeeded else failed { reason = unlines ["", show either, show expected] } where - builder = System.Nix.Derivation.ATerm.buildDerivation storeDir derivation0 + builder = System.Nix.Derivation.ATerm.buildTraditionalDerivation storeDir derivation0 text = Data.Text.Lazy.Builder.toLazyText builder result = Data.Attoparsec.Text.Lazy.parse - (System.Nix.Derivation.ATerm.parseDerivation storeDir (name derivation0)) + (System.Nix.Derivation.ATerm.parseTraditionalDerivation storeDir) text - either, expected :: Either String (Derivation' TraditionalDerivationInputs DerivationOutput) + either, expected :: Either String (TraditionalDerivation' TraditionalDerivationInputs FreeformDerivationOutputs) either = Data.Attoparsec.Text.Lazy.eitherResult result diff --git a/hnix-store-core/hnix-store-core.cabal b/hnix-store-core/hnix-store-core.cabal index 8b545410..8582895c 100644 --- a/hnix-store-core/hnix-store-core.cabal +++ b/hnix-store-core/hnix-store-core.cabal @@ -87,6 +87,7 @@ library , deepseq , dependent-sum > 0.7 , dependent-sum-template >= 0.2.0.1 && < 0.3 + , dependent-monoidal-map , filepath , hashable -- Required for crypton low-level type convertion diff --git a/hnix-store-core/src/System/Nix/Derivation.hs b/hnix-store-core/src/System/Nix/Derivation.hs index b4080b63..e6f6dc73 100644 --- a/hnix-store-core/src/System/Nix/Derivation.hs +++ b/hnix-store-core/src/System/Nix/Derivation.hs @@ -2,7 +2,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} -- | Shared types @@ -12,7 +15,18 @@ module System.Nix.Derivation , Derivation , BasicDerivation - , DerivationOutput(..) + , DerivationType(..) + , DerivationOutputs + , InputAddressedDerivationOutput(..) + , FixedDerivationOutput(..) + , ContentAddressedDerivationOutput(..) + + , FreeformDerivationOutput(..) + , FreeformDerivationOutputs + , toSpecificOutput + , fromSpecificOutput + , toSpecificOutputs + , fromSpecificOutputs , DerivationInputs(..) , derivationInputsFromSingleDerivedPath @@ -24,31 +38,113 @@ module System.Nix.Derivation , derivedPathMapToSet ) where +import Control.Monad (when) import Control.DeepSeq (NFData(..)) import Crypto.Hash (Digest) +import Data.Constraint.Extras +import Data.Constraint.Extras.TH (deriveArgDict) +import Data.Dependent.Map.Monoidal qualified as MonoidalDMap import Data.Dependent.Sum (DSum(..)) +import Data.Functor.Identity +import Data.GADT.Compare.TH +import Data.GADT.Show.TH +import Data.GADT.DeepSeq (GNFData(..)) +import Data.Kind import Data.Map (Map) +import Data.Map qualified import Data.Map.Monoidal (MonoidalMap) import Data.Map.Monoidal qualified import Data.Set (Set) import Data.Set qualified import Data.Some (Some(..)) -import Data.GADT.DeepSeq (GNFData(..)) import Data.Text (Text) import Data.These (These(..), fromThese) import Data.Vector (Vector) -import GHC.Generics (Generic) +import GHC.Generics (Generic, (:.:)(..)) import System.Nix.ContentAddress (ContentAddressMethod) -import System.Nix.Hash (HashAlgo) import System.Nix.DerivedPath (SingleDerivedPath(..)) -import System.Nix.StorePath (StorePath, StorePathName) -import System.Nix.OutputName (OutputName) +import System.Nix.Hash (HashAlgo) +import System.Nix.OutputName (OutputName, outputStoreObjectName) +import System.Nix.StorePath (StoreDir, StorePath, StorePathName) +import System.Nix.StorePath.ContentAddressed + +-- | The type of the derivation +data DerivationType :: Type -> Type where + + -- | The outputs are input-addressed. + DerivationType_InputAddressing :: DerivationType InputAddressedDerivationOutput + + -- | The outputs are content-addressed, and the content addresses are + -- "fixed", i.e. required to be specific values (or the build fails) + -- by the derivation itself. + DerivationType_Fixed :: DerivationType FixedDerivationOutput + + -- | The outputs are content-addressed, and the content addresses are + -- "floating", i.e. they are not required to be a specific value like + -- in the "fixed" case. + DerivationType_ContentAddressing :: DerivationType ContentAddressedDerivationOutput + +---------------- + +type DerivationOutputs = DSum DerivationType (Map OutputName) + +-- | An output of a Nix derivation +data InputAddressedDerivationOutput = InputAddressedDerivationOutput + { iaPath :: StorePath + -- ^ Path where the output will be saved + } + deriving (Eq, Generic, Ord, Show) + +instance NFData InputAddressedDerivationOutput + +data FixedDerivationOutput = FixedDerivationOutput + { fMethod :: ContentAddressMethod + -- ^ How this output is serialized into a hash / what sort of CA + -- store path is used. + , fHash :: DSum HashAlgo Digest + -- ^ Expected hash of this output + } + deriving (Eq, Generic, Ord, Show) + +instance NFData FixedDerivationOutput + +data ContentAddressedDerivationOutput = ContentAddressedDerivationOutput + { caMethod :: ContentAddressMethod + -- ^ How this output is serialized into a hash / what sort of CA + -- store path is used. + , caHashAlgo :: Some HashAlgo + -- ^ What sort of hash function is used with the above + -- content-addressing method to produce the (content-addressed) + -- store path we'll use for the output. + } + deriving (Eq, Generic, Ord, Show) + +instance NFData ContentAddressedDerivationOutput -data Derivation' inputs output = Derivation +---------------- + +-- | TODO this should go in `dependent-sum` +instance (GNFData k, Has' NFData k v) => NFData (DSum k v) where + rnf (x :=> y) = grnf x `seq` has' @NFData @v x (rnf y) + +-- | TODO this needs a home +instance GNFData Digest where + grnf = rnf + +---------------- + +deriveGEq ''DerivationType +deriveGCompare ''DerivationType +deriveGShow ''DerivationType +deriveArgDict ''DerivationType + +---------------- + +data Derivation' inputs outputs = Derivation { name :: StorePathName -- ^ Name of the derivation, needed for calculating output paths - , outputs :: Map OutputName output + , outputs :: outputs -- ^ Outputs produced by this derivation where keys are output names , inputs :: inputs -- ^ Inputs (sources and derivations) @@ -66,11 +162,11 @@ data Derivation' inputs output = Derivation instance (NFData inputs, NFData output) => NFData (Derivation' inputs output) -- | A regular Nix derivation -type Derivation = Derivation' DerivationInputs DerivationOutput +type Derivation = Derivation' DerivationInputs DerivationOutputs -- | A Nix derivation that only depends on other store objects directly, -- not (the outputs of) other derivations -type BasicDerivation = Derivation' (Set StorePath) DerivationOutput +type BasicDerivation = Derivation' (Set StorePath) DerivationOutputs ---------------- @@ -149,35 +245,120 @@ derivedPathMapToSet (DerivedPathMap m) = Data.Set.unions $ fmap ---------------- --- | An output of a Nix derivation -data DerivationOutput - = InputAddressedDerivationOutput - { path :: StorePath - -- ^ Path where the output will be saved - } - | FixedDerivationOutput - { method :: ContentAddressMethod - -- ^ How this output is serialized into a hash / what sort of CA +-- | This single data type can represent all types of derivation +-- outputs, but allows for many illegal states. This is here as a +-- simpler intermediate data type to aid with derivation parsing (both +-- JSON and ATerm). +data FreeformDerivationOutput + = FreeformDerivationOutput + { mPath :: Maybe StorePath + -- ^ Optional: Path where the output will be saved + , mContentAddressing :: Maybe (ContentAddressMethod, DSum HashAlgo (Maybe :.: Digest)) + -- ^ Optional: How this output is serialized into a hash / what sort of CA -- store path is used. - , hash :: DSum HashAlgo Digest - -- ^ Expected hash of this output - } - | ContentAddressedDerivationOutput - { method :: ContentAddressMethod - -- ^ How this output is serialized into a hash / what sort of CA - -- store path is used. - , hashAlgo :: Some HashAlgo - -- ^ What sort of hash function is used with the above - -- content-addressing method to produce the (content-addressed) - -- store path we'll use for the output. + -- + -- Inner Optional: Expected hash algorithm and also possibly hash + -- for this output. } deriving (Eq, Generic, Ord, Show) -instance NFData DerivationOutput +instance NFData FreeformDerivationOutput --- | TODO this should go in `dependent-sum` -instance (GNFData k, GNFData v) => NFData (DSum k v) where - rnf (x :=> y) = grnf x `seq` grnf y --- | TODO this needs a home -instance GNFData Digest where - grnf = rnf +-- | TODO upstream +instance NFData (f (g a)) => NFData ((f :.: g) a) where + rnf (Comp1 x) = rnf x + +type FreeformDerivationOutputs = Map OutputName FreeformDerivationOutput + +-- | Convert a 'FreeformDerivationOutput' to a derivation type and +-- output +toSpecificOutput + :: forall m + . MonadFail m + => StoreDir + -> StorePathName + -> OutputName + -> FreeformDerivationOutput + -> m (DSum DerivationType Identity) +toSpecificOutput storeDir drvName outputName = \case + FreeformDerivationOutput + { mPath = Just path + , mContentAddressing = Nothing + } -> pure $ DerivationType_InputAddressing :=> Identity (InputAddressedDerivationOutput path) + FreeformDerivationOutput + { mPath = Just path + , mContentAddressing = Just (method, algo :=> Comp1 (Just hash)) + } -> do + fullOutputName <- either (fail . show) pure $ + outputStoreObjectName drvName outputName + let hash' = algo :=> hash + let expectedPath = makeFixedOutputPath storeDir method hash' mempty fullOutputName + when (path /= expectedPath) $ + fail "fixed output path does not match info" + pure $ DerivationType_Fixed :=> Identity (FixedDerivationOutput method hash') + FreeformDerivationOutput + { mPath = Nothing + , mContentAddressing = Just (method, algo :=> Comp1 Nothing) + } -> pure $ DerivationType_ContentAddressing :=> Identity (ContentAddressedDerivationOutput method (Some algo)) + _ -> fail "Invalid combination of path/method/hash being present or absent" + +-- | Convert a derivation type and output to a 'FreeformDerivationOutput' +fromSpecificOutput + :: StoreDir + -> StorePathName + -> OutputName + -> DSum DerivationType Identity + -> FreeformDerivationOutput +fromSpecificOutput storeDir drvName outputName (ty :=> Identity output) = case ty of + DerivationType_InputAddressing -> + case output of + InputAddressedDerivationOutput { iaPath } -> + FreeformDerivationOutput + { mPath = Just iaPath + , mContentAddressing = Nothing + } + DerivationType_Fixed -> + case output of + FixedDerivationOutput { fMethod, fHash = hash'@(algo :=> hash) } -> + FreeformDerivationOutput + { mPath = Just $ makeFixedOutputPath storeDir fMethod hash' mempty + $ either (error . show) id -- TODO do better + $ outputStoreObjectName drvName outputName + , mContentAddressing = Just (fMethod, algo :=> Comp1 (Just hash)) + } + DerivationType_ContentAddressing -> + case output of + ContentAddressedDerivationOutput { caMethod, caHashAlgo = Some algo } -> + FreeformDerivationOutput + { mPath = Nothing + , mContentAddressing = Just (caMethod, algo :=> Comp1 Nothing) + } + +-- | Convert a map of 'FreeformDerivationOutput' to 'DerivationOutputs' +toSpecificOutputs + :: forall m + . MonadFail m + => StoreDir + -> StorePathName + -> FreeformDerivationOutputs + -> m DerivationOutputs +toSpecificOutputs storeDir drvName outputs = do + -- Traverse and convert each output + converted <- Data.Map.traverseWithKey (toSpecificOutput storeDir drvName) outputs + -- Group outputs by their derivation type + let grouped = foldMap + (\(name, ty :=> Identity output) -> MonoidalDMap.singleton ty $ Data.Map.singleton name output) + (Data.Map.toList converted) + case MonoidalDMap.toList grouped of + [res] -> pure res + _ -> fail "derivation outputs did not agree on derivation type" + +-- | Convert a map of specific derivation outputs to a 'FreeformDerivationOutputs' +fromSpecificOutputs + :: StoreDir + -> StorePathName + -> DerivationOutputs + -> FreeformDerivationOutputs +fromSpecificOutputs storeDir drvName (drvType :=> outputs) = + flip Data.Map.mapWithKey outputs $ \outputName output -> + fromSpecificOutput storeDir drvName outputName $ drvType :=> Identity output diff --git a/hnix-store-remote/hnix-store-remote.cabal b/hnix-store-remote/hnix-store-remote.cabal index 065e33c1..c324d156 100644 --- a/hnix-store-remote/hnix-store-remote.cabal +++ b/hnix-store-remote/hnix-store-remote.cabal @@ -180,6 +180,7 @@ test-suite remote , hnix-store-core , hnix-store-remote , hnix-store-tests + , hnix-store-aterm , bytestring , crypton , some > 1.0.5 && < 2 diff --git a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs index b17b045a..2325b831 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Client.hs @@ -147,14 +147,23 @@ buildDerivation sp mode = do $ Data.Text.IO.readFile $ System.Nix.StorePath.storePathToFilePath sd sp case Data.Attoparsec.Text.parseOnly - (System.Nix.Derivation.ATerm.parseDerivation sd $ System.Nix.StorePath.storePathName sp) drvContents of + (System.Nix.Derivation.ATerm.parseTraditionalDerivation sd) drvContents of Left e -> throwError $ RemoteStoreError_DerivationParse e Right drv -> do - let drv' = drv - { System.Nix.Derivation.inputs = - System.Nix.Derivation.Traditional.traditionalSrcs - (System.Nix.Derivation.inputs drv) - } + let name = System.Nix.StorePath.storePathName sp + outputs <- case + System.Nix.Derivation.toSpecificOutputs sd name $ + System.Nix.Derivation.Traditional.anonOutputs drv + of + Nothing -> throwError $ RemoteStoreError_DerivationParse "TODO get error" + Just os -> pure os + let drv' = System.Nix.Derivation.Traditional.withName name $ + System.Nix.Derivation.Traditional.TraditionalDerivation + { System.Nix.Derivation.Traditional.anonOutputs = outputs + , System.Nix.Derivation.Traditional.anonInputs = + System.Nix.Derivation.Traditional.traditionalSrcs + (System.Nix.Derivation.Traditional.anonInputs drv) + } doReq (BuildDerivation sp drv' mode) -- | Build paths if they are an actual derivations. 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 e2672e74..78fa4217 100644 --- a/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs +++ b/hnix-store-remote/src/System/Nix/Store/Remote/Serializer.hs @@ -151,11 +151,6 @@ import System.Nix.ContentAddress (ContentAddress) import System.Nix.ContentAddress qualified import System.Nix.Derivation.Traditional import System.Nix.Derivation - ( BasicDerivation - , Derivation'(..) - , DerivationOutput(..) - -- , DerivationInputs(..) - ) import System.Nix.DerivedPath (DerivedPath(..), ParseOutputsError) import System.Nix.DerivedPath qualified import System.Nix.FileContentAddress (FileIngestionMethod(..)) @@ -683,17 +678,15 @@ namedDigest = Serializer derivationOutput :: StoreDir - -> StorePathName - -> OutputName - -> NixSerializer SError DerivationOutput -derivationOutput storeDir drvName outputName' = Serializer + -> NixSerializer SError FreeformDerivationOutput +derivationOutput storeDir = Serializer { getS = do rawPath <- getS text rawMethodHashAlgo <- getS text rawHash <- getS text - parseRawDerivationOutput storeDir drvName outputName' $ RawDerivationOutput {..} + parseRawDerivationOutput storeDir $ RawDerivationOutput {..} , putS = \output -> do - let RawDerivationOutput {..} = renderRawDerivationOutput storeDir drvName outputName' output + let RawDerivationOutput {..} = renderRawDerivationOutput storeDir output putS text rawPath putS text rawMethodHashAlgo putS text rawHash @@ -703,25 +696,23 @@ derivationOutput storeDir drvName outputName' = Serializer basicDerivation :: StoreDir - -> StorePathName - -> NixSerializer SError BasicDerivation -basicDerivation storeDir drvName = Serializer + -> NixSerializer SError (TraditionalDerivation' (Set StorePath) FreeformDerivationOutputs) +basicDerivation storeDir = Serializer { getS = do - outputs <- getS $ mapS' $ depTup outputName $ derivationOutput storeDir drvName - inputs <- getS $ set $ storePath storeDir - platform <- getS text - builder <- getS text - args <- getS $ vector text - env <- getS $ mapS text text - let name = drvName - pure $ Derivation{..} - , putS = \Derivation{..} -> do - putS (mapS' $ depTup outputName $ derivationOutput storeDir drvName) outputs - putS (set $ storePath storeDir) inputs - putS text platform - putS text builder - putS (vector text) args - putS (mapS text text) env + anonOutputs <- getS $ mapS' $ tup outputName $ derivationOutput storeDir + anonInputs <- getS $ set $ storePath storeDir + anonPlatform <- getS text + anonBuilder <- getS text + anonArgs <- getS $ vector text + anonEnv <- getS $ mapS text text + pure $ TraditionalDerivation{..} + , putS = \TraditionalDerivation{..} -> do + putS (mapS' $ tup outputName $ derivationOutput storeDir) anonOutputs + putS (set $ storePath storeDir) anonInputs + putS text anonPlatform + putS text anonBuilder + putS (vector text) anonArgs + putS (mapS text text) anonEnv } -- * DerivedPath @@ -1082,9 +1073,13 @@ storeRequest storeDir pv = Serializer WorkerOp_BuildDerivation -> mapGetE $ do path <- getS $ storePath storeDir - drv <- getS (basicDerivation storeDir $ System.Nix.StorePath.storePathName path) + let name = System.Nix.StorePath.storePathName path + drv0 <- getS $ basicDerivation storeDir + let drv1 = withName name drv0 + outputs <- toSpecificOutputs storeDir name $ outputs drv1 + let drv2 = drv1 { outputs = outputs } buildMode' <- getS buildMode - pure $ Some (BuildDerivation path drv buildMode') + pure $ Some (BuildDerivation path drv2 buildMode') WorkerOp_CollectGarbage -> mapGetE $ do gcOptionsOperation <- getS enum @@ -1223,11 +1218,13 @@ storeRequest storeDir pv = Serializer putS (set $ derivedPath storeDir pv) derived putS buildMode buildMode' - Some (BuildDerivation path drv buildMode') -> do + Some (BuildDerivation path drv0 buildMode') -> do putS workerOp WorkerOp_BuildDerivation putS (storePath storeDir) path - putS (basicDerivation storeDir $ name drv) drv + let drv1 = drv0 { outputs = fromSpecificOutputs storeDir (name drv0) $ outputs drv0 } + let drv2 = withoutName drv1 + putS (basicDerivation storeDir) drv2 putS buildMode buildMode' Some (CollectGarbage GCOptions{..}) -> do diff --git a/hnix-store-remote/tests/NixSerializerSpec.hs b/hnix-store-remote/tests/NixSerializerSpec.hs index 34ce3d0a..efda9a16 100644 --- a/hnix-store-remote/tests/NixSerializerSpec.hs +++ b/hnix-store-remote/tests/NixSerializerSpec.hs @@ -10,7 +10,7 @@ import Test.QuickCheck (Gen, arbitrary, forAll, suchThat) import System.Nix.Arbitrary () import System.Nix.Build (BuildResult(..)) -import System.Nix.Derivation qualified +import System.Nix.Derivation.Traditional qualified import System.Nix.Store.Remote.Arbitrary () import System.Nix.Store.Remote.Serializer import System.Nix.Store.Remote.Types.Logger (Logger(..)) @@ -114,7 +114,8 @@ spec = parallel $ do prop "SHA512" $ roundtripS . digest @SHA512 prop "Derivation" $ \sd drv -> - roundtripS (basicDerivation sd $ System.Nix.Derivation.name drv) drv + roundtripS (basicDerivation sd) $ + System.Nix.Derivation.Traditional.withoutName drv prop "ProtoVersion" $ roundtripS @() protoVersion diff --git a/hnix-store-tests/hnix-store-tests.cabal b/hnix-store-tests/hnix-store-tests.cabal index 54f9ac2d..3f9c99da 100644 --- a/hnix-store-tests/hnix-store-tests.cabal +++ b/hnix-store-tests/hnix-store-tests.cabal @@ -62,6 +62,7 @@ library , hnix-store-core >= 0.8 , bytestring , containers + , constraints-extras , crypton , dependent-sum > 0.7 , generic-arbitrary < 1.1 @@ -97,5 +98,8 @@ test-suite props , hnix-store-core , hnix-store-tests , attoparsec + , dependent-sum + , containers , text , hspec + , QuickCheck diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs index 0a80b7d6..2d08ca15 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Derivation.hs @@ -1,13 +1,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -- due to recent generic-arbitrary {-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} {-# OPTIONS_GHC -Wno-orphans #-} module System.Nix.Arbitrary.Derivation where +import Data.Constraint.Extras import Data.Dependent.Sum import Data.Either (isRight) +import Data.Map (Map) import Data.Map qualified import Data.Map.Monoidal import Data.Some @@ -17,42 +20,95 @@ import Data.Vector.Arbitrary () import Test.QuickCheck.Arbitrary.Generic import Test.QuickCheck.Gen -import System.Nix.Derivation +import System.Nix.StorePath import System.Nix.ContentAddress import System.Nix.Hash +import System.Nix.Derivation import System.Nix.OutputName import System.Nix.Arbitrary.ContentAddress () -import System.Nix.Arbitrary.Hash () +import System.Nix.Arbitrary.Hash (genDSum) import System.Nix.Arbitrary.StorePath () import System.Nix.Arbitrary.OutputName () +-- | ensure output path name is not too long +shortEnoughOutputName :: StorePathName -> Gen (OutputName) +shortEnoughOutputName drvName = + arbitrary `suchThat` \outputName -> isRight $ outputStoreObjectName drvName outputName + +-- | Also ensures at least one output +shortEnoughOutputsName :: Arbitrary a => StorePathName -> Gen (Map OutputName a) +shortEnoughOutputsName drvName = fmap Data.Map.fromList $ listOf1 $ (,) <$> shortEnoughOutputName drvName <*> arbitrary + +shortEnoughOutputs :: StorePathName -> Gen DerivationOutputs +shortEnoughOutputs drvName = + genDSum arbitrary $ \tag -> has @Arbitrary tag $ shortEnoughOutputsName drvName + +-- | Ensure a valid combination +ensureValidMethodAlgo :: ContentAddressMethod -> HashAlgo a -> Bool +ensureValidMethodAlgo = \case + ContentAddressMethod_Text -> \case + HashAlgo_SHA256 -> True + _ -> False + _ -> \_ -> True + instance ( Arbitrary inputs , Arbitrary output - , Arg (Derivation' inputs output) inputs - , Arg (Derivation' inputs output) output - ) => Arbitrary (Derivation' inputs output) + , Arg (Derivation' inputs (Map OutputName output)) inputs + , Arg (Derivation' inputs (Map OutputName output)) output + ) => Arbitrary (Derivation' inputs (Map OutputName output)) where - arbitrary = genericArbitrary `suchThat` \drv -> - -- ensure output path name is not too long - all (\on -> isRight $ outputStoreObjectName (name drv) on) - $ Data.Map.keys (outputs drv) + arbitrary = do + drv <- genericArbitrary + om <- shortEnoughOutputsName $ name drv + let + drv' = drv { outputs = om } + -- type inference hint + _ = [drv, drv'] + pure drv' shrink = genericShrink -instance Arbitrary DerivationOutput where - arbitrary = genericArbitrary `suchThat` \case - InputAddressedDerivationOutput {} -> True - FixedDerivationOutput {method, hash = hashAlgo :=> _} -> f method hashAlgo - ContentAddressedDerivationOutput {method, hashAlgo = Some hashAlgo } -> f method hashAlgo - where - -- Ensure a valid combination - f = \case - ContentAddressMethod_Text -> \case - HashAlgo_SHA256 -> True - _ -> False - _ -> \_ -> True +instance + ( Arbitrary inputs + , Arg (Derivation' inputs DerivationOutputs) inputs + ) => Arbitrary (Derivation' inputs DerivationOutputs) + where + arbitrary = do + drv <- genericArbitrary + os <- shortEnoughOutputs $ name drv + let + drv' = drv { outputs = os } + -- type inference hint + _ = [drv, drv'] + pure drv' shrink = genericShrink +deriving via GenericArbitrary FreeformDerivationOutput + instance Arbitrary FreeformDerivationOutput + +deriving via GenericArbitrary InputAddressedDerivationOutput + instance Arbitrary InputAddressedDerivationOutput + +instance Arbitrary FixedDerivationOutput where + arbitrary = genericArbitrary `suchThat` + \(FixedDerivationOutput {fMethod, fHash = hashAlgo :=> _}) -> + ensureValidMethodAlgo fMethod hashAlgo + +instance Arbitrary ContentAddressedDerivationOutput where + arbitrary = genericArbitrary `suchThat` + \(ContentAddressedDerivationOutput {caMethod, caHashAlgo = Some hashAlgo }) -> + ensureValidMethodAlgo caMethod hashAlgo + +instance Arbitrary (Some DerivationType) where + arbitrary = + oneof + $ pure + <$> [ + Some DerivationType_InputAddressing + , Some DerivationType_Fixed + , Some DerivationType_ContentAddressing + ] + deriving via GenericArbitrary DerivationInputs instance Arbitrary DerivationInputs diff --git a/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs b/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs index fe4aa266..639a94c6 100644 --- a/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs +++ b/hnix-store-tests/src/System/Nix/Arbitrary/Hash.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + -- due to recent generic-arbitrary {-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -5,12 +10,15 @@ module System.Nix.Arbitrary.Hash where import Data.ByteString (ByteString) import Data.ByteString.Arbitrary () +import Data.Constraint.Extras import Crypto.Hash (Digest, MD5(..), SHA1(..), SHA256(..), SHA512(..)) import Data.Dependent.Sum (DSum((:=>))) import Data.Some (Some(Some)) +import GHC.Generics + import System.Nix.Hash (HashAlgo(..)) -import Test.QuickCheck (Arbitrary(arbitrary), oneof) +import Test.QuickCheck (Arbitrary(arbitrary), Gen, oneof) import Crypto.Hash qualified @@ -28,15 +36,7 @@ instance Arbitrary (Digest SHA256) where instance Arbitrary (Digest SHA512) where arbitrary = Crypto.Hash.hash @ByteString <$> arbitrary --- * Arbitrary @DSum HashAlgo Digest@s - -instance Arbitrary (DSum HashAlgo Digest) where - arbitrary = oneof - [ (HashAlgo_MD5 :=>) <$> arbitrary - , (HashAlgo_SHA1 :=>) <$> arbitrary - , (HashAlgo_SHA256 :=>) <$> arbitrary - , (HashAlgo_SHA512 :=>) <$> arbitrary - ] +-- * Arbitrary @Some HashAlgo@ instance Arbitrary (Some HashAlgo) where arbitrary = @@ -48,3 +48,15 @@ instance Arbitrary (Some HashAlgo) where , Some HashAlgo_SHA256 , Some HashAlgo_SHA512 ] + +-- * TODO Upstream + +genDSum :: Gen (Some f) -> (forall a. f a -> Gen (g a)) -> Gen (DSum f g) +genDSum genTag genValue = genTag >>= \(Some tag) -> + (tag :=>) <$> genValue tag + +instance (Arbitrary (Some f), Has' Arbitrary f g) => Arbitrary (DSum f g) where + arbitrary = genDSum arbitrary (\tag -> has' @Arbitrary @g tag arbitrary) + +instance (Arbitrary (f (g a))) => Arbitrary ((f :.: g) a) where + arbitrary = Comp1 <$> arbitrary diff --git a/hnix-store-tests/tests/DerivationSpec.hs b/hnix-store-tests/tests/DerivationSpec.hs index ccaa5046..c317a470 100644 --- a/hnix-store-tests/tests/DerivationSpec.hs +++ b/hnix-store-tests/tests/DerivationSpec.hs @@ -3,13 +3,12 @@ module DerivationSpec where import Data.Functor.Identity (Identity(..)) import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck import Test.Hspec.Nix (roundtrips) import System.Nix.Arbitrary () +import System.Nix.Arbitrary.Derivation import System.Nix.Derivation - ( derivationInputsFromSingleDerivedPath - , derivationInputsToDerivedPaths - ) spec :: Spec spec = do @@ -21,3 +20,26 @@ spec = do roundtrips (foldMap derivationInputsFromSingleDerivedPath) (Identity . derivationInputsToDerivedPaths) + + describe "DerivationOutput" $ do + prop "roundtrips to FreeformDerivationOutput" $ \storeDir storePathName output -> do + outputName <- generate $ shortEnoughOutputName storePathName + roundtrips + (fromSpecificOutput storeDir storePathName outputName) + (toSpecificOutput @Maybe storeDir storePathName outputName) + output + + -- Sometimes infinite loops, not sure why + + -- describe "DerivationOutputs" $ do + -- prop "roundtrips to FreeformDerivationOutputs" $ verboseCheck $ \storeDir storePathName -> do + -- outputs <- generate $ shortEnoughOutputs storePathName + -- _ <- roundtrips + -- (fromSpecificOutputs storeDir storePathName) + -- (toSpecificOutputs @Maybe storeDir storePathName) + -- outputs + -- pure () + +-- -- | Useful for debugging +-- instance MonadFail (Either String) where +-- fail = Left