{-# language DataKinds #-}
{-# language NamedFieldPuns #-}
{-# language RecordWildCards #-}
{-# language PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@

module Nix.Effects.Derivation ( defaultDerivationStrict ) where

import           Nix.Prelude             hiding ( readFile )
import           GHC.Exception                  ( ErrorCall(ErrorCall) )
import           Data.Char                      ( isAscii
                                                , isAlphaNum
                                                )
import qualified Data.HashMap.Lazy             as M
import qualified Data.HashMap.Strict           as MS ( insert )
import qualified Data.HashSet                  as S
import           Data.Foldable                  ( foldl )
import qualified Data.Map.Strict               as Map
import qualified Data.Set                      as Set
import qualified Data.Text                     as Text

import           Text.Megaparsec
import           Text.Megaparsec.Char

import qualified "cryptonite" Crypto.Hash      as Hash -- 2021-07-05: Attrocity of Haskell hashing situation, in HNix we ended-up with 2 hash package dependencies @{hashing, cryptonite}@

import           Nix.Atoms
import           Nix.Expr.Types          hiding ( Recursive )
import           Nix.Convert
import           Nix.Effects
import           Nix.Exec                       ( MonadNix
                                                , callFunc
                                                )
import           Nix.Frames
import           Nix.Json                       ( toJSONNixString )
import           Nix.Render
import           Nix.String
import           Nix.String.Coerce
import           Nix.Value
import           Nix.Value.Monad

import qualified System.Nix.ReadonlyStore      as Store
import qualified System.Nix.Hash               as Store
import qualified System.Nix.StorePath          as Store


--  2021-07-17: NOTE: Derivation consists of @"keys"@ @"vals"@ (of text), so underlining type boundary currently stops here.
data Derivation = Derivation
  { Derivation -> Text
name :: Text
  , Derivation -> Map Text Text
outputs :: Map Text Text
  , Derivation -> (Set Text, Map Text [Text])
inputs :: (Set Text, Map Text [Text])
  , Derivation -> Text
platform :: Text
  , Derivation -> Text
builder :: Text -- should be typed as a store path
  , Derivation -> [Text]
args :: [ Text ]
  , Derivation -> Map Text Text
env :: Map Text Text
  , Derivation -> Maybe SomeNamedDigest
mFixed :: Maybe Store.SomeNamedDigest
  , Derivation -> HashMode
hashMode :: HashMode
  , Derivation -> Bool
useJson :: Bool
  }
  deriving Int -> Derivation -> ShowS
[Derivation] -> ShowS
Derivation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Derivation] -> ShowS
$cshowList :: [Derivation] -> ShowS
show :: Derivation -> String
$cshow :: Derivation -> String
showsPrec :: Int -> Derivation -> ShowS
$cshowsPrec :: Int -> Derivation -> ShowS
Show

data HashMode = Flat | Recursive
  deriving (Int -> HashMode -> ShowS
[HashMode] -> ShowS
HashMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HashMode] -> ShowS
$cshowList :: [HashMode] -> ShowS
show :: HashMode -> String
$cshow :: HashMode -> String
showsPrec :: Int -> HashMode -> ShowS
$cshowsPrec :: Int -> HashMode -> ShowS
Show, HashMode -> HashMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HashMode -> HashMode -> Bool
$c/= :: HashMode -> HashMode -> Bool
== :: HashMode -> HashMode -> Bool
$c== :: HashMode -> HashMode -> Bool
Eq)

makeStorePathName :: (Framed e m) => Text -> m Store.StorePathName
makeStorePathName :: forall e (m :: * -> *). Framed e m => Text -> m StorePathName
makeStorePathName Text
name = case Text -> Either String StorePathName
Store.makeStorePathName Text
name of
  Left String
err -> forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"Invalid name '" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Text
name forall a. Semigroup a => a -> a -> a
<> String
"' for use in a store path: " forall a. Semigroup a => a -> a -> a
<> String
err
  Right StorePathName
spname -> forall (f :: * -> *) a. Applicative f => a -> f a
pure StorePathName
spname

parsePath :: (Framed e m) => Text -> m Store.StorePath
parsePath :: forall e (m :: * -> *). Framed e m => Text -> m StorePath
parsePath Text
p = case String -> ByteString -> Either String StorePath
Store.parsePath String
"/nix/store" (forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
p) of
  Left String
err -> forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"Cannot parse store path " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Text
p forall a. Semigroup a => a -> a -> a
<> String
":\n" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show String
err
  Right StorePath
path -> forall (f :: * -> *) a. Applicative f => a -> f a
pure StorePath
path

writeDerivation :: (Framed e m, MonadStore m) => Derivation -> m Store.StorePath
writeDerivation :: forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
Derivation -> m StorePath
writeDerivation drv :: Derivation
drv@Derivation{(Set Text, Map Text [Text])
inputs :: (Set Text, Map Text [Text])
inputs :: Derivation -> (Set Text, Map Text [Text])
inputs, Text
name :: Text
name :: Derivation -> Text
name} = do
  let (Set Text
inputSrcs, Map Text [Text]
inputDrvs) = (Set Text, Map Text [Text])
inputs
  Set StorePath
references <- forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e (m :: * -> *). Framed e m => Text -> m StorePath
parsePath (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Set Text
inputSrcs forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => [a] -> Set a
Set.fromList (forall k a. Map k a -> [k]
Map.keys Map Text [Text]
inputDrvs))
  StorePath
path <- forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
Text -> Text -> StorePathSet -> Bool -> m StorePath
addTextToStore (Text -> Text -> Text
Text.append Text
name Text
".drv") (Derivation -> Text
unparseDrv Derivation
drv) (forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set StorePath
references) Bool
False
  forall e (m :: * -> *). Framed e m => Text -> m StorePath
parsePath forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce StorePath
path

-- | Traverse the graph of inputDrvs to replace fixed output derivations with their fixed output hash.
-- this avoids propagating changes to their .drv when the output hash stays the same.
hashDerivationModulo :: (MonadNix e t f m, MonadState (b, KeyMap Text) m) => Derivation -> m (Hash.Digest Hash.SHA256)
hashDerivationModulo :: forall e t (f :: * -> *) (m :: * -> *) b.
(MonadNix e t f m, MonadState (b, KeyMap Text) m) =>
Derivation -> m (Digest SHA256)
hashDerivationModulo
  Derivation
    { mFixed :: Derivation -> Maybe SomeNamedDigest
mFixed = Just (Store.SomeDigest (Digest a
digest :: Hash.Digest hashType))
    , Map Text Text
outputs :: Map Text Text
outputs :: Derivation -> Map Text Text
outputs
    , HashMode
hashMode :: HashMode
hashMode :: Derivation -> HashMode
hashMode
    } =
  case forall k a. Map k a -> [(k, a)]
Map.toList Map Text Text
outputs of
    [(Text
"out", Text
path)] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash @ByteString @Hash.SHA256 forall a b. (a -> b) -> a -> b
$
        forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$
          Text
"fixed:out"
          forall a. Semigroup a => a -> a -> a
<> (if HashMode
hashMode forall a. Eq a => a -> a -> Bool
== HashMode
Recursive then Text
":r" else forall a. Monoid a => a
mempty)
          forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> (forall a. NamedAlgo a => Text
Store.algoName @hashType)
          forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. BaseEncoding -> Digest a -> Text
Store.encodeDigestWith BaseEncoding
Store.Base16 Digest a
digest
          forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
path
    [(Text, Text)]
_outputsList -> forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"This is weird. A fixed output drv should only have one output named 'out'. Got " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show [(Text, Text)]
_outputsList
hashDerivationModulo
  drv :: Derivation
drv@Derivation
    { inputs :: Derivation -> (Set Text, Map Text [Text])
inputs = ( Set Text
inputSrcs
               , Map Text [Text]
inputDrvs
               )
    } =
  do
    KeyMap Text
cache <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> b
snd
    Map Text [Text]
inputsModulo <-
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
          (\(Text
path, [Text]
outs) ->
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe
              (do
                Derivation
drv' <- forall e (m :: * -> *).
(Framed e m, MonadFile m) =>
Path -> m Derivation
readDerivation forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. ToString a => a -> String
toString Text
path
                Text
hash <- forall a. BaseEncoding -> Digest a -> Text
Store.encodeDigestWith BaseEncoding
Store.Base16 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e t (f :: * -> *) (m :: * -> *) b.
(MonadNix e t f m, MonadState (b, KeyMap Text) m) =>
Derivation -> m (Digest SHA256)
hashDerivationModulo Derivation
drv'
                pure (Text
hash, [Text]
outs)
              )
              (\ Text
hash -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
hash, [Text]
outs))
              (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
path KeyMap Text
cache)
          )
          (forall k a. Map k a -> [(k, a)]
Map.toList Map Text [Text]
inputDrvs)
    pure $ forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash @ByteString @Hash.SHA256 forall a b. (a -> b) -> a -> b
$ forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Derivation -> Text
unparseDrv forall a b. (a -> b) -> a -> b
$ Derivation
drv {inputs :: (Set Text, Map Text [Text])
inputs = (Set Text
inputSrcs, Map Text [Text]
inputsModulo)}

unparseDrv :: Derivation -> Text
unparseDrv :: Derivation -> Text
unparseDrv Derivation{Bool
[Text]
Maybe SomeNamedDigest
(Set Text, Map Text [Text])
Text
Map Text Text
HashMode
useJson :: Bool
hashMode :: HashMode
mFixed :: Maybe SomeNamedDigest
env :: Map Text Text
args :: [Text]
builder :: Text
platform :: Text
inputs :: (Set Text, Map Text [Text])
outputs :: Map Text Text
name :: Text
useJson :: Derivation -> Bool
hashMode :: Derivation -> HashMode
mFixed :: Derivation -> Maybe SomeNamedDigest
env :: Derivation -> Map Text Text
args :: Derivation -> [Text]
builder :: Derivation -> Text
platform :: Derivation -> Text
inputs :: Derivation -> (Set Text, Map Text [Text])
outputs :: Derivation -> Map Text Text
name :: Derivation -> Text
..} =
  Text -> Text -> Text
Text.append
    Text
"Derive"
    forall a b. (a -> b) -> a -> b
$ [Text] -> Text
parens
      [ -- outputs: [("out", "/nix/store/.....-out", "", ""), ...]
        [Text] -> Text
serializeList forall a b. (a -> b) -> a -> b
$
          (Text, Text) -> Text
produceOutputInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList Map Text Text
outputs
      , -- inputDrvs
        [Text] -> Text
serializeList forall a b. (a -> b) -> a -> b
$
          (\(Text
path, [Text]
outs) ->
            [Text] -> Text
parens [Text -> Text
s Text
path, [Text] -> Text
serializeList forall a b. (a -> b) -> a -> b
$ Text -> Text
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> [a]
sort [Text]
outs]
          ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList (forall a b. (a, b) -> b
snd (Set Text, Map Text [Text])
inputs)
      , -- inputSrcs
        [Text] -> Text
serializeList forall a b. (a -> b) -> a -> b
$ Text -> Text
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList (forall a b. (a, b) -> a
fst (Set Text, Map Text [Text])
inputs)
      , Text -> Text
s Text
platform
      , Text -> Text
s Text
builder
      , -- run script args
        [Text] -> Text
serializeList forall a b. (a -> b) -> a -> b
$ Text -> Text
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
args
      , -- env (key value pairs)
        [Text] -> Text
serializeList forall a b. (a -> b) -> a -> b
$ (\(Text
k, Text
v) -> [Text] -> Text
parens [Text -> Text
s Text
k, Text -> Text
s Text
v]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList Map Text Text
env
      ]
  where
    produceOutputInfo :: (Text, Text) -> Text
produceOutputInfo (Text
outputName, Text
outputPath) =
      let prefix :: Text
prefix = if HashMode
hashMode forall a. Eq a => a -> a -> Bool
== HashMode
Recursive then Text
"r:" else forall a. Monoid a => a
mempty in
      [Text] -> Text
parens forall a b. (a -> b) -> a -> b
$ (Text -> Text
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall a b. (a -> b) -> a -> b
$ ([Text
outputName, Text
outputPath] forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          [forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty]
          (\ (Store.SomeDigest (Digest a
digest :: Hash.Digest hashType)) ->
            [Text
prefix forall a. Semigroup a => a -> a -> a
<> forall a. NamedAlgo a => Text
Store.algoName @hashType, forall a. BaseEncoding -> Digest a -> Text
Store.encodeDigestWith BaseEncoding
Store.Base16 Digest a
digest]
          )
          Maybe SomeNamedDigest
mFixed
    parens :: [Text] -> Text
    parens :: [Text] -> Text
parens [Text]
ts = [Text] -> Text
Text.concat [Text
"(", Text -> [Text] -> Text
Text.intercalate Text
"," [Text]
ts, Text
")"]

    serializeList   :: [Text] -> Text
    serializeList :: [Text] -> Text
serializeList   [Text]
ls = [Text] -> Text
Text.concat [Text
"[", Text -> [Text] -> Text
Text.intercalate Text
"," [Text]
ls, Text
"]"]

    s :: Text -> Text
s = Char -> Text -> Text
Text.cons Char
'\"' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Char -> Text
`Text.snoc` Char
'\"') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
escape

    escape :: Char -> Text
    escape :: Char -> Text
escape Char
'\\' = Text
"\\\\"
    escape Char
'\"' = Text
"\\\""
    escape Char
'\n' = Text
"\\n"
    escape Char
'\r' = Text
"\\r"
    escape Char
'\t' = Text
"\\t"
    escape Char
c = forall x. One x => OneItem x -> x
one Char
c

readDerivation :: (Framed e m, MonadFile m) => Path -> m Derivation
readDerivation :: forall e (m :: * -> *).
(Framed e m, MonadFile m) =>
Path -> m Derivation
readDerivation Path
path = do
  Text
content <- forall (m :: * -> *). MonadFile m => Path -> m Text
readFile Path
path
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (\ ParseErrorBundle Text ()
err -> forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"Failed to parse " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Path
path forall a. Semigroup a => a -> a -> a
<> String
":\n" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show ParseErrorBundle Text ()
err)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec () Text Derivation
derivationParser (coerce :: forall a b. Coercible a b => a -> b
coerce Path
path) Text
content)

derivationParser :: Parsec () Text Derivation
derivationParser :: Parsec () Text Derivation
derivationParser = do
  Text
_ <- ParsecT () Text Identity Text
"Derive("
  [(Text, Text, Text, Text)]
fullOutputs <- forall a. Parsec () Text a -> Parsec () Text [a]
serializeList forall a b. (a -> b) -> a -> b
$
    (\[Text
n, Text
p, Text
ht, Text
h] -> (Text
n, Text
p, Text
ht, Text
h)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parsec () Text a -> Parsec () Text [a]
parens ParsecT () Text Identity Text
s
  Text
_ <- ParsecT () Text Identity Text
","
  Map Text [Text]
inputDrvs   <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parsec () Text a -> Parsec () Text [a]
serializeList
    (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (ParsecT () Text Identity Text
"(" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT () Text Identity Text
s forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT () Text Identity Text
",") (forall a. Parsec () Text a -> Parsec () Text [a]
serializeList ParsecT () Text Identity Text
s forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT () Text Identity Text
")"))
  Text
_ <- ParsecT () Text Identity Text
","
  Set Text
inputSrcs   <- forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parsec () Text a -> Parsec () Text [a]
serializeList ParsecT () Text Identity Text
s
  Text
_ <- ParsecT () Text Identity Text
","
  Text
platform    <- ParsecT () Text Identity Text
s
  Text
_ <- ParsecT () Text Identity Text
","
  Text
builder     <- ParsecT () Text Identity Text
s
  Text
_ <- ParsecT () Text Identity Text
","
  [Text]
args        <- forall a. Parsec () Text a -> Parsec () Text [a]
serializeList ParsecT () Text Identity Text
s
  Text
_ <- ParsecT () Text Identity Text
","
  Map Text Text
env         <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. Parsec () Text a -> Parsec () Text [a]
serializeList forall a b. (a -> b) -> a -> b
$ (\[Text
a, Text
b] -> (Text
a, Text
b)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parsec () Text a -> Parsec () Text [a]
parens ParsecT () Text Identity Text
s
  Text
_ <- ParsecT () Text Identity Text
")"
  forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

  let outputs :: Map Text Text
outputs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ (\(Text
a, Text
b, Text
_, Text
_) -> (Text
a, Text
b)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text, Text, Text)]
fullOutputs
  let (Maybe SomeNamedDigest
mFixed, HashMode
hashMode) = [(Text, Text, Text, Text)] -> (Maybe SomeNamedDigest, HashMode)
parseFixed [(Text, Text, Text, Text)]
fullOutputs
  let name :: Text
name = forall a. Monoid a => a
mempty -- FIXME (extract from file path ?)
  let useJson :: Bool
useJson = forall x. One x => OneItem x -> x
one Text
"__json" forall a. Eq a => a -> a -> Bool
== forall k a. Map k a -> [k]
Map.keys Map Text Text
env

  pure $ Derivation {inputs :: (Set Text, Map Text [Text])
inputs = (Set Text
inputSrcs, Map Text [Text]
inputDrvs), Bool
[Text]
Maybe SomeNamedDigest
Text
Map Text Text
HashMode
useJson :: Bool
name :: Text
hashMode :: HashMode
mFixed :: Maybe SomeNamedDigest
outputs :: Map Text Text
env :: Map Text Text
args :: [Text]
builder :: Text
platform :: Text
useJson :: Bool
hashMode :: HashMode
mFixed :: Maybe SomeNamedDigest
env :: Map Text Text
args :: [Text]
builder :: Text
platform :: Text
outputs :: Map Text Text
name :: Text
..}
 where
  s :: Parsec () Text Text
  s :: ParsecT () Text Identity Text
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"\"" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill (ParsecT () Text Identity Char
escaped forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT () Text Identity (Token Text)
regular) (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"\"")
  escaped :: ParsecT () Text Identity Char
escaped = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
    (   Char
'\n' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"n"
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char
'\r' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"r"
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char
'\t' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"t"
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
    )
  regular :: ParsecT () Text Identity (Token Text)
regular = forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf [Char
'\\', Char
'"']

  wrap :: Tokens s -> Tokens s -> f a -> f [a]
wrap Tokens s
o Tokens s
c f a
p =
    forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
o forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
sepBy f a
p (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
",") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
c

  parens :: Parsec () Text a -> Parsec () Text [a]
  parens :: forall a. Parsec () Text a -> Parsec () Text [a]
parens = forall {f :: * -> *} {e} {s} {a}.
(MonadParsec e s f, IsString (Tokens s)) =>
Tokens s -> Tokens s -> f a -> f [a]
wrap Tokens Text
"(" Tokens Text
")"
  serializeList :: Parsec () Text a -> Parsec () Text [a]
  serializeList :: forall a. Parsec () Text a -> Parsec () Text [a]
serializeList = forall {f :: * -> *} {e} {s} {a}.
(MonadParsec e s f, IsString (Tokens s)) =>
Tokens s -> Tokens s -> f a -> f [a]
wrap Tokens Text
"[" Tokens Text
"]"

  parseFixed :: [(Text, Text, Text, Text)] -> (Maybe Store.SomeNamedDigest, HashMode)
  parseFixed :: [(Text, Text, Text, Text)] -> (Maybe SomeNamedDigest, HashMode)
parseFixed [(Text, Text, Text, Text)]
fullOutputs = case [(Text, Text, Text, Text)]
fullOutputs of
    [(Text
"out", Text
_path, Text
rht, Text
hash)] | Text
rht forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty Bool -> Bool -> Bool
&& Text
hash forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty ->
      let
        (Text
hashType, HashMode
hashMode) = case Text -> Text -> [Text]
Text.splitOn Text
":" Text
rht of
          [Text
"r", Text
ht] -> (Text
ht, HashMode
Recursive)
          [Text
ht] ->      (Text
ht, HashMode
Flat)
          [Text]
_ -> forall a t. (HasCallStack, IsText t) => t -> a
error forall a b. (a -> b) -> a -> b
$ Text
"Unsupported hash type for output of fixed-output derivation in .drv file: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show [(Text, Text, Text, Text)]
fullOutputs
      in
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          -- Please, no longer `error show` after migrating to Text
          (\ String
err -> forall a t. (HasCallStack, IsText t) => t -> a
error forall a b. (a -> b) -> a -> b
$ forall b a. (Show a, IsString b) => a -> b
show forall a b. (a -> b) -> a -> b
$ String
"Unsupported hash " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (Text
hashType forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
hash) forall a. Semigroup a => a -> a -> a
<> String
"in .drv file: " forall a. Semigroup a => a -> a -> a
<> String
err)
          (\ SomeNamedDigest
digest -> (forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeNamedDigest
digest, HashMode
hashMode))
          (Text -> Text -> Either String SomeNamedDigest
Store.mkNamedDigest Text
hashType Text
hash)
    [(Text, Text, Text, Text)]
_ -> (forall a. Maybe a
Nothing, HashMode
Flat)


defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, KeyMap Text) m) => NValue t f m -> m (NValue t f m)
defaultDerivationStrict :: forall e t (f :: * -> *) (m :: * -> *) b.
(MonadNix e t f m, MonadState (b, KeyMap Text) m) =>
NValue t f m -> m (NValue t f m)
defaultDerivationStrict NValue t f m
val = do
    HashMap Text (NValue t f m)
s <- forall k2 k1 v.
(Eq k2, Hashable k2) =>
(k1 -> k2) -> HashMap k1 v -> HashMap k2 v
M.mapKeys coerce :: forall a b. Coercible a b => a -> b
coerce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *) v. FromValue a m v => v -> m a
fromValue @(AttrSet (NValue t f m)) NValue t f m
val
    (Derivation
drv, HashSet StringContext
ctx) <- forall (m :: * -> *) a.
Monad m =>
WithStringContextT m a -> m (a, HashSet StringContext)
runWithStringContextT' forall a b. (a -> b) -> a -> b
$ forall e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
KeyMap (NValue t f m) -> WithStringContextT m Derivation
buildDerivationWithContext HashMap Text (NValue t f m)
s
    StorePathName
drvName <- forall e (m :: * -> *). Framed e m => Text -> m StorePathName
makeStorePathName forall a b. (a -> b) -> a -> b
$ Derivation -> Text
name Derivation
drv
    let
      inputs :: (Set Text, Map Text [Text])
inputs = HashSet StringContext -> (Set Text, Map Text [Text])
toStorePaths HashSet StringContext
ctx
      ifNotJsonModEnv :: (Map Text Text -> Map Text Text) -> Map Text Text
ifNotJsonModEnv Map Text Text -> Map Text Text
f =
        forall a. a -> a -> Bool -> a
bool Map Text Text -> Map Text Text
f forall a. a -> a
id (Derivation -> Bool
useJson Derivation
drv)
          (Derivation -> Map Text Text
env Derivation
drv)

    -- Compute the output paths, and add them to the environment if needed.
    -- Also add the inputs, just computed from the strings contexts.
    Derivation
drv' <- case Derivation -> Maybe SomeNamedDigest
mFixed Derivation
drv of
      Just (Store.SomeDigest Digest a
digest) -> do
        let
          out :: Text
out = StorePath -> Text
pathToText forall a b. (a -> b) -> a -> b
$ forall hashAlgo.
NamedAlgo hashAlgo =>
String -> Bool -> Digest hashAlgo -> StorePathName -> StorePath
Store.makeFixedOutputPath String
"/nix/store" (Derivation -> HashMode
hashMode Derivation
drv forall a. Eq a => a -> a -> Bool
== HashMode
Recursive) Digest a
digest StorePathName
drvName
          env' :: Map Text Text
env' = (Map Text Text -> Map Text Text) -> Map Text Text
ifNotJsonModEnv forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"out" Text
out
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Derivation
drv { (Set Text, Map Text [Text])
inputs :: (Set Text, Map Text [Text])
inputs :: (Set Text, Map Text [Text])
inputs, env :: Map Text Text
env = Map Text Text
env', outputs :: Map Text Text
outputs = forall x. One x => OneItem x -> x
one (Text
"out", Text
out) }

      Maybe SomeNamedDigest
Nothing -> do
        Digest SHA256
hash <- forall e t (f :: * -> *) (m :: * -> *) b.
(MonadNix e t f m, MonadState (b, KeyMap Text) m) =>
Derivation -> m (Digest SHA256)
hashDerivationModulo forall a b. (a -> b) -> a -> b
$ Derivation
drv
          { (Set Text, Map Text [Text])
inputs :: (Set Text, Map Text [Text])
inputs :: (Set Text, Map Text [Text])
inputs
        --, outputs = Map.map (const "") (outputs drv)  -- not needed, this is already the case
          , env :: Map Text Text
env =
              (Map Text Text -> Map Text Text) -> Map Text Text
ifNotJsonModEnv
                (\ Map Text Text
baseEnv ->
                  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                    (\Map Text Text
m Text
k -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
k forall a. Monoid a => a
mempty Map Text Text
m)
                    Map Text Text
baseEnv
                    (forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ Derivation -> Map Text Text
outputs Derivation
drv)
                )
          }
        Map Text Text
outputs' <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall a b. (a -> b) -> a -> b
$ forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\Text
o Text
_ -> forall {f :: * -> *} {e} {h}.
(MonadReader e f, Has e Frames, MonadThrow f, NamedAlgo h) =>
Text -> Digest h -> StorePathName -> f Text
makeOutputPath Text
o Digest SHA256
hash StorePathName
drvName) forall a b. (a -> b) -> a -> b
$ Derivation -> Map Text Text
outputs Derivation
drv
        pure $ Derivation
drv
          { (Set Text, Map Text [Text])
inputs :: (Set Text, Map Text [Text])
inputs :: (Set Text, Map Text [Text])
inputs
          , outputs :: Map Text Text
outputs = Map Text Text
outputs'
          , env :: Map Text Text
env = (Map Text Text -> Map Text Text) -> Map Text Text
ifNotJsonModEnv (Map Text Text
outputs' forall a. Semigroup a => a -> a -> a
<>)
          }

    (coerce :: forall a b. Coercible a b => a -> b
coerce @Text @VarName -> VarName
drvPath) <- StorePath -> Text
pathToText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
Derivation -> m StorePath
writeDerivation Derivation
drv'

    -- Memoize here, as it may be our last chance in case of readonly stores.
    Text
drvHash <- forall a. BaseEncoding -> Digest a -> Text
Store.encodeDigestWith BaseEncoding
Store.Base16 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e t (f :: * -> *) (m :: * -> *) b.
(MonadNix e t f m, MonadState (b, KeyMap Text) m) =>
Derivation -> m (Digest SHA256)
hashDerivationModulo Derivation
drv'
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
MS.insert (coerce :: forall a b. Coercible a b => a -> b
coerce VarName
drvPath) Text
drvHash

    let
      outputsWithContext :: Map Text NixString
outputsWithContext =
        forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
          (\Text
out (coerce :: forall a b. Coercible a b => a -> b
coerce -> VarName
path) -> StringContext -> VarName -> NixString
mkNixStringWithSingletonContext (ContextFlavor -> VarName -> StringContext
StringContext (Text -> ContextFlavor
DerivationOutput Text
out) VarName
drvPath) VarName
path)
          (Derivation -> Map Text Text
outputs Derivation
drv')
      drvPathWithContext :: NixString
drvPathWithContext = StringContext -> VarName -> NixString
mkNixStringWithSingletonContext (ContextFlavor -> VarName -> StringContext
StringContext ContextFlavor
AllOutputs VarName
drvPath) VarName
drvPath
      attrSet :: HashMap Text (Free (NValue' t f m) a)
attrSet = forall {w :: * -> *} {t} {m :: * -> *} {a}.
(Comonad w, Applicative w) =>
NixString -> Free (NValue' t w m) a
NVStr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ((Text
"drvPath", NixString
drvPathWithContext) forall a. a -> [a] -> [a]
: forall k a. Map k a -> [(k, a)]
Map.toList Map Text NixString
outputsWithContext)
    -- TODO: Add location information for all the entries.
    --              here --v
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {w :: * -> *} {t} {m :: * -> *} {a}.
(Comonad w, Applicative w) =>
PositionSet
-> AttrSet (Free (NValue' t w m) a) -> Free (NValue' t w m) a
NVSet forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall k2 k1 v.
(Eq k2, Hashable k2) =>
(k1 -> k2) -> HashMap k1 v -> HashMap k2 v
M.mapKeys coerce :: forall a b. Coercible a b => a -> b
coerce forall {t} {m :: * -> *} {a}. HashMap Text (Free (NValue' t f m) a)
attrSet

  where

    pathToText :: StorePath -> Text
pathToText = forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> ByteString
Store.storePathToRawFilePath

    makeOutputPath :: Text -> Digest h -> StorePathName -> f Text
makeOutputPath Text
o Digest h
h StorePathName
n = do
      StorePathName
name <- forall e (m :: * -> *). Framed e m => Text -> m StorePathName
makeStorePathName forall a b. (a -> b) -> a -> b
$ StorePathName -> Text
Store.unStorePathName StorePathName
n forall a. Semigroup a => a -> a -> a
<> if Text
o forall a. Eq a => a -> a -> Bool
== Text
"out" then forall a. Monoid a => a
mempty else Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
o
      pure $ StorePath -> Text
pathToText forall a b. (a -> b) -> a -> b
$ forall h.
NamedAlgo h =>
String -> ByteString -> Digest h -> StorePathName -> StorePath
Store.makeStorePath String
"/nix/store" (ByteString
"output:" forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
o) Digest h
h StorePathName
name

    toStorePaths :: HashSet StringContext -> (Set Text, Map Text [Text])
    toStorePaths :: HashSet StringContext -> (Set Text, Map Text [Text])
toStorePaths = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (p :: * -> * -> *).
Bifunctor p =>
StringContext
-> p (Set Text) (Map Text [Text]) -> p (Set Text) (Map Text [Text])
addToInputs) forall a. Monoid a => a
mempty

    addToInputs :: Bifunctor p => StringContext -> p (Set Text) (Map Text [Text])  -> p (Set Text) (Map Text [Text])
    addToInputs :: forall (p :: * -> * -> *).
Bifunctor p =>
StringContext
-> p (Set Text) (Map Text [Text]) -> p (Set Text) (Map Text [Text])
addToInputs (StringContext ContextFlavor
kind (coerce :: forall a b. Coercible a b => a -> b
coerce -> Text
path)) =
      case ContextFlavor
kind of
        ContextFlavor
DirectPath -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert Text
path
        DerivationOutput Text
o -> forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) Text
path forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one Text
o
        ContextFlavor
AllOutputs ->
          -- TODO: recursive lookup. See prim_derivationStrict
          -- XXX: When is this really used ?
          forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Not implemented: derivations depending on a .drv file are not yet supported."


-- | Build a derivation in a context collecting string contexts.
-- This is complex from a typing standpoint, but it allows to perform the
-- full computation without worrying too much about all the string's contexts.
buildDerivationWithContext :: forall e t f m. (MonadNix e t f m) => KeyMap (NValue t f m) -> WithStringContextT m Derivation
buildDerivationWithContext :: forall e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
KeyMap (NValue t f m) -> WithStringContextT m Derivation
buildDerivationWithContext KeyMap (NValue t f m)
drvAttrs = do
    -- Parse name first, so we can add an informative frame
    Text
drvName     <- forall {v} {a}.
FromValue v m (NValue' t f m (NValue t f m)) =>
Text -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttr   Text
"name"                      forall a b. (a -> b) -> a -> b
$ MonadNix e t f m => Text -> WithStringContextT m Text
assertDrvStoreName forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *).
Monad m =>
NixString -> WithStringContextT m Text
extractNixString
    forall s a.
(Framed e m, Exception s) =>
NixLevel -> s -> WithStringContextT m a -> WithStringContextT m a
withFrame' NixLevel
Info (String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"While evaluating derivation " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Text
drvName) forall a b. (a -> b) -> a -> b
$ do

      Bool
useJson     <- forall {v} {a}.
FromValue v m (NValue' t f m (NValue t f m)) =>
Text
-> a -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttrOr Text
"__structuredAttrs" Bool
False     forall (f :: * -> *) a. Applicative f => a -> f a
pure
      Bool
ignoreNulls <- forall {v} {a}.
FromValue v m (NValue' t f m (NValue t f m)) =>
Text
-> a -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttrOr Text
"__ignoreNulls"     Bool
False     forall (f :: * -> *) a. Applicative f => a -> f a
pure

      [Text]
args        <- forall {v} {a}.
FromValue v m (NValue' t f m (NValue t f m)) =>
Text
-> a -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttrOr Text
"args"              forall a. Monoid a => a
mempty  forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
Monad m =>
NixString -> WithStringContextT m Text
extractNixString forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a.
(FromValue a m (NValue' t f m (NValue t f m)), MonadNix e t f m) =>
NValue t f m -> WithStringContextT m a
fromValue')
      Text
builder     <- forall {v} {a}.
FromValue v m (NValue' t f m (NValue t f m)) =>
Text -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttr   Text
"builder"                     forall (m :: * -> *).
Monad m =>
NixString -> WithStringContextT m Text
extractNixString
      Text
platform    <- forall {v} {a}.
FromValue v m (NValue' t f m (NValue t f m)) =>
Text -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttr   Text
"system"                    forall a b. (a -> b) -> a -> b
$ MonadNix e t f m => Text -> WithStringContextT m Text
assertNonNull forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< MonadNix e t f m => NixString -> WithStringContextT m Text
extractNoCtx
      Maybe Text
mHash       <- forall {v} {a}.
FromValue v m (NValue' t f m (NValue t f m)) =>
Text
-> a -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttrOr Text
"outputHash"        forall a. Monoid a => a
mempty  forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< MonadNix e t f m => NixString -> WithStringContextT m Text
extractNoCtx
      HashMode
hashMode    <- forall {v} {a}.
FromValue v m (NValue' t f m (NValue t f m)) =>
Text
-> a -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttrOr Text
"outputHashMode"    HashMode
Flat    forall a b. (a -> b) -> a -> b
$ MonadNix e t f m => Text -> WithStringContextT m HashMode
parseHashMode forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< MonadNix e t f m => NixString -> WithStringContextT m Text
extractNoCtx
      [Text]
outputs     <- forall {v} {a}.
FromValue v m (NValue' t f m (NValue t f m)) =>
Text
-> a -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttrOr Text
"outputs"       (forall x. One x => OneItem x -> x
one Text
"out") forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (MonadNix e t f m => NixString -> WithStringContextT m Text
extractNoCtx forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a.
(FromValue a m (NValue' t f m (NValue t f m)), MonadNix e t f m) =>
NValue t f m -> WithStringContextT m a
fromValue')

      Maybe SomeNamedDigest
mFixedOutput <-
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
          (\ Text
hash -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text]
outputs forall a. Eq a => a -> a -> Bool
/= forall x. One x => OneItem x -> x
one Text
"out") forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Multiple outputs are not supported for fixed-output derivations"
            Text
hashType <- forall {v} {a}.
FromValue v m (NValue' t f m (NValue t f m)) =>
Text -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttr Text
"outputHashAlgo" MonadNix e t f m => NixString -> WithStringContextT m Text
extractNoCtx
            SomeNamedDigest
digest <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Text -> Either String SomeNamedDigest
Store.mkNamedDigest Text
hashType Text
hash
            pure $ forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeNamedDigest
digest)
          Maybe Text
mHash

      -- filter out null values if needed.
      KeyMap (NValue t f m)
attrs <-
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
          forall a. a -> a -> Bool -> a
bool
            (forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMap (NValue t f m)
drvAttrs)
            (forall v1 v2 k. (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
M.mapMaybe forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                  (\case
                    NVConstant NAtom
NNull -> forall a. Maybe a
Nothing
                    NValue t f m
_value           -> forall a. a -> Maybe a
Just NValue t f m
_value
                  )
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v (m :: * -> *). MonadValue v m => v -> m v
demand
                )
                KeyMap (NValue t f m)
drvAttrs
            )
            Bool
ignoreNulls

      Map Text Text
env <- if Bool
useJson
        then do
          NixString
jsonString :: NixString <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
NValue t f m -> m NixString
toJSONNixString forall a b. (a -> b) -> a -> b
$ forall {w :: * -> *} {t} {m :: * -> *} {a}.
(Comonad w, Applicative w) =>
PositionSet
-> AttrSet (Free (NValue' t w m) a) -> Free (NValue' t w m) a
NVSet forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall k2 k1 v.
(Eq k2, Hashable k2) =>
(k1 -> k2) -> HashMap k1 v -> HashMap k2 v
M.mapKeys coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$
            forall a. [Text] -> KeyMap a -> KeyMap a
deleteKeys [ Text
"args", Text
"__ignoreNulls", Text
"__structuredAttrs" ] KeyMap (NValue t f m)
attrs
          Text
rawString :: Text <- forall (m :: * -> *).
Monad m =>
NixString -> WithStringContextT m Text
extractNixString NixString
jsonString
          pure $ forall x. One x => OneItem x -> x
one (Text
"__json", Text
rawString)
        else
          forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
Monad m =>
NixString -> WithStringContextT m Text
extractNixString forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e t (f :: * -> *) (m :: * -> *).
(Framed e m, MonadStore m, MonadThrow m,
 MonadDataErrorContext t f m, MonadValue (NValue t f m) m) =>
(NValue t f m -> NValue t f m -> m (NValue t f m))
-> CopyToStoreMode -> NValue t f m -> m NixString
coerceAnyToNixString forall e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
NValue t f m -> NValue t f m -> m (NValue t f m)
callFunc CopyToStoreMode
CopyToStore) forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
M.toList forall a b. (a -> b) -> a -> b
$ forall a. [Text] -> KeyMap a -> KeyMap a
deleteKeys [ Text
"args", Text
"__ignoreNulls" ] KeyMap (NValue t f m)
attrs

      pure $ Derivation { Text
platform :: Text
platform :: Text
platform, Text
builder :: Text
builder :: Text
builder, [Text]
args :: [Text]
args :: [Text]
args, Map Text Text
env :: Map Text Text
env :: Map Text Text
env,  HashMode
hashMode :: HashMode
hashMode :: HashMode
hashMode, Bool
useJson :: Bool
useJson :: Bool
useJson
        , name :: Text
name = Text
drvName
        , outputs :: Map Text Text
outputs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ (, forall a. Monoid a => a
mempty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
outputs
        , mFixed :: Maybe SomeNamedDigest
mFixed = Maybe SomeNamedDigest
mFixedOutput
        , inputs :: (Set Text, Map Text [Text])
inputs = forall a. Monoid a => a
mempty -- stub for now
        }
  where

    -- common functions, lifted to WithStringContextT

    fromValue' :: (FromValue a m (NValue' t f m (NValue t f m)), MonadNix e t f m) => NValue t f m -> WithStringContextT m a
    fromValue' :: forall a.
(FromValue a m (NValue' t f m (NValue t f m)), MonadNix e t f m) =>
NValue t f m -> WithStringContextT m a
fromValue' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *) v. FromValue a m v => v -> m a
fromValue

    withFrame' :: (Framed e m, Exception s) => NixLevel -> s -> WithStringContextT m a -> WithStringContextT m a
    withFrame' :: forall s a.
(Framed e m, Exception s) =>
NixLevel -> s -> WithStringContextT m a -> WithStringContextT m a
withFrame' NixLevel
level s
f = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e (m :: * -> *) a.
(Framed e m, Exception s) =>
NixLevel -> s -> m a -> m a
withFrame NixLevel
level s
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

    -- shortcuts to get the (forced) value of an KeyMap field

    getAttrOr' :: forall v a. (MonadNix e t f m, FromValue v m (NValue' t f m (NValue t f m)))
      => Text -> m a -> (v -> WithStringContextT m a) -> WithStringContextT m a
    getAttrOr' :: forall v a.
(MonadNix e t f m, FromValue v m (NValue' t f m (NValue t f m))) =>
Text
-> m a -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttrOr' Text
n m a
d v -> WithStringContextT m a
f = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
n KeyMap (NValue t f m)
drvAttrs of
      Maybe (NValue t f m)
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
d
      Just NValue t f m
v  -> forall s a.
(Framed e m, Exception s) =>
NixLevel -> s -> WithStringContextT m a -> WithStringContextT m a
withFrame' NixLevel
Info (String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"While evaluating attribute '" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Text
n forall a. Semigroup a => a -> a -> a
<> String
"'") forall a b. (a -> b) -> a -> b
$
                   v -> WithStringContextT m a
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
(FromValue a m (NValue' t f m (NValue t f m)), MonadNix e t f m) =>
NValue t f m -> WithStringContextT m a
fromValue' NValue t f m
v

    getAttrOr :: Text
-> a -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttrOr Text
n = forall v a.
(MonadNix e t f m, FromValue v m (NValue' t f m (NValue t f m))) =>
Text
-> m a -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttrOr' Text
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

    getAttr :: Text -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttr Text
n = forall v a.
(MonadNix e t f m, FromValue v m (NValue' t f m (NValue t f m))) =>
Text
-> m a -> (v -> WithStringContextT m a) -> WithStringContextT m a
getAttrOr' Text
n (forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"Required attribute '" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Text
n forall a. Semigroup a => a -> a -> a
<> String
"' not found.")

    -- Test validity for fields

    assertDrvStoreName :: MonadNix e t f m => Text -> WithStringContextT m Text
    assertDrvStoreName :: MonadNix e t f m => Text -> WithStringContextT m Text
assertDrvStoreName Text
name = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
      let invalid :: Char -> Bool
invalid Char
c = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (String
"+-._?=" :: String)) -- isAlphaNum allows non-ascii chars.
      let failWith :: String -> m a
failWith String
reason = forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"Store name " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Text
name forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> String
reason
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
"." Text -> Text -> Bool
`Text.isPrefixOf` Text
name)    forall a b. (a -> b) -> a -> b
$ forall {e} {m :: * -> *} {a}.
(MonadReader e m, Has e Frames, MonadThrow m) =>
String -> m a
failWith String
"cannot start with a period"
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Int
Text.length Text
name forall a. Ord a => a -> a -> Bool
> Int
211)        forall a b. (a -> b) -> a -> b
$ forall {e} {m :: * -> *} {a}.
(MonadReader e m, Has e Frames, MonadThrow m) =>
String -> m a
failWith String
"must be no longer than 211 characters"
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> Text -> Bool
Text.any Char -> Bool
invalid Text
name)         forall a b. (a -> b) -> a -> b
$ forall {e} {m :: * -> *} {a}.
(MonadReader e m, Has e Frames, MonadThrow m) =>
String -> m a
failWith String
"contains some invalid character"
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
".drv" Text -> Text -> Bool
`Text.isSuffixOf` Text
name) forall a b. (a -> b) -> a -> b
$ forall {e} {m :: * -> *} {a}.
(MonadReader e m, Has e Frames, MonadThrow m) =>
String -> m a
failWith String
"is not allowed to end in '.drv'"
      pure Text
name

    extractNoCtx :: MonadNix e t f m => NixString -> WithStringContextT m Text
    extractNoCtx :: MonadNix e t f m => NixString -> WithStringContextT m Text
extractNoCtx NixString
ns =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"The string " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show NixString
ns forall a. Semigroup a => a -> a -> a
<> String
" is not allowed to have a context.")
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (NixString -> Maybe Text
getStringNoContext NixString
ns)

    assertNonNull :: MonadNix e t f m => Text -> WithStringContextT m Text
    assertNonNull :: MonadNix e t f m => Text -> WithStringContextT m Text
assertNonNull Text
t = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
Text.null Text
t) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Value must not be empty"
      pure Text
t

    parseHashMode :: MonadNix e t f m => Text -> WithStringContextT m HashMode
    parseHashMode :: MonadNix e t f m => Text -> WithStringContextT m HashMode
parseHashMode = \case
      Text
"flat" ->      forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMode
Flat
      Text
"recursive" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMode
Recursive
      Text
other -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"Hash mode " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Text
other forall a. Semigroup a => a -> a -> a
<> String
" is not valid. It must be either 'flat' or 'recursive'"

    -- Other helpers

    deleteKeys :: [Text] -> KeyMap a -> KeyMap a
    deleteKeys :: forall a. [Text] -> KeyMap a -> KeyMap a
deleteKeys [Text]
keys KeyMap a
attrSet = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete) KeyMap a
attrSet [Text]
keys