Merge #554: Implementation of derivationStrict primOp & use of the St…

…ore 0.4

Implement derivationStrict primOp

Closes #364

cabal.project

@@ -1,2 +1,8 @@
 packages:
   ./hnix.cabal
+
+source-repository-package
+    type: git
+    location: https://github.com/Anton-Latukha/cryptohash-sha512
+    tag: 48f827eb09a73ad5ee43dd397a06ebdbf51ab856
+

default.nix

@@ -91,7 +91,7 @@
 #   , nixos-20.03  # Last stable release, gets almost no updates to recipes, gets only required backports
 #   ...
 #   }
-, rev ? "24eb3f87fc610f18de7076aee7c5a84ac5591e3e"
+, rev ? "8ba15f6383c74e981d8038fa19cc77ed0c53ba22"
 
 , pkgs ?
     if builtins.compareVersions builtins.nixVersion "2.0" < 0
@@ -111,30 +111,30 @@
 
 let
 
- getDefaultGHC = "ghc${
-    (
-      # Remove '.' from the string 8.8.4 -> 884
-      pkgs.lib.stringAsChars (c: if c == "." then "" else c)
-        # Get default GHC version,
-        (pkgs.lib.getVersion pkgs.haskellPackages.ghc)
-    )
-  }";
-
- compilerPackage =
-   if ((compiler == "") || (compiler == "default"))
-     then getDefaultGHC
-     else compiler;
-
-  #  2020-05-23: NOTE: Currently HNix-store needs no overlay
-  # hnix-store-src = pkgs.fetchFromGitHub {
-  #   owner = "haskell-nix";
-  #   repo = "hnix-store";
-  #   rev = "0.2.0.0";
-  #   sha256 = "1qf5rn43d46vgqqgmwqdkjh78rfg6bcp4kypq3z7mx46sdpzvb78";
-  # };
+  getDefaultGHC = "ghc${
+      (
+        # Remove '.' from the string 8.8.4 -> 884
+        pkgs.lib.stringAsChars (c: if c == "." then "" else c)
+          # Get default GHC version,
+          (pkgs.lib.getVersion pkgs.haskellPackages.ghc)
+      )
+    }";
+
+  compilerPackage =
+    if ((compiler == "") || (compiler == "default"))
+      then getDefaultGHC
+      else compiler;
+
+  #  2020-12-31: NOTE: Remove after `hnix-store 0.4` arrives into Nixpkgs
+  hnix-store-src = pkgs.fetchFromGitHub {
+    owner = "haskell-nix";
+    repo = "hnix-store";
+    rev = "fd09d29b8bef4904058f033d693e7d928a4a92dc";
+    sha256 = "0fxig1ckzknm5g19jzg7rrcpz7ssn4iiv9bs9hff9gfy3ciq4zrs";
+  };
 
   overlay = pkgs.lib.foldr pkgs.lib.composeExtensions (_: _: {}) [
-    # (import "${hnix-store-src}/overlay.nix")
+    (import "${hnix-store-src}/overlay.nix" pkgs pkgs.haskell.lib)
     (self: super:
       pkgs.lib.optionalAttrs withHoogle {
       ghc = super.ghc // { withPackages = super.ghc.withHoogle; };
@@ -223,6 +223,18 @@ let
     root = packageRoot;
 
     overrides = self: super: {
+      # 2020-12-07 We really want cryptohash-sha512, but it conflicts with
+      # recent versions of base, for seemingly no valid reason.
+      # As the update is slow to happen, just jailbreak here
+      # See https://github.com/haskell-hvr/cryptohash-sha512 PRs 3, 5 and issue 4
+      # See also https://github.com/NixOS/nixpkgs/pull/106333 for a temporary fix.
+      cryptohash-sha512 = pkgs.haskell.lib.unmarkBroken ( pkgs.haskell.lib.doJailbreak super.cryptohash-sha512 );
+
+      # 2020-12-07 hnix-store-remote fails when trying to connect to a real hnix daemon.
+      # probably due to nix sandbox restrictions.
+      # Upstream issue @ https://github.com/haskell-nix/hnix-store/issues/80
+      hnix-store-remote = pkgs.haskell.lib.removeConfigureFlag super.hnix-store-remote "-fio-testsuite";
+
       # 2020-08-04 hnix uses custom LayoutOptions and therefore is
       # likely to be affected by the change in the ribbon width
       # calculation in prettyprinter-1.7.0.

hnix.cabal

@@ -11,9 +11,19 @@ license:        BSD3
 license-file:   LICENSE
 build-type:     Simple
 cabal-version:  >= 1.10
+data-dir:       data/
+data-files:
+    nix/corepkgs/buildenv.nix
+    nix/corepkgs/unpack-channel.nix
+    nix/corepkgs/derivation.nix
+    nix/corepkgs/fetchurl.nix
+    nix/corepkgs/imported-drv-to-derivation.nix
 extra-source-files:
     data/nix/corepkgs/buildenv.nix
+    data/nix/corepkgs/unpack-channel.nix
     data/nix/corepkgs/derivation.nix
+    data/nix/corepkgs/fetchurl.nix
+    data/nix/corepkgs/imported-drv-to-derivation.nix
     data/nix/tests/lang/binary-data
     data/nix/tests/lang/data
     data/nix/tests/lang/dir1/a.nix
@@ -341,6 +351,7 @@ library
       Nix.Convert
       Nix.Effects
       Nix.Effects.Basic
+      Nix.Effects.Derivation
       Nix.Eval
       Nix.Exec
       Nix.Expr
@@ -401,8 +412,9 @@ library
     , gitrev >= 1.1.0 && < 1.4
     , hashable >= 1.2.5 && < 1.4
     , hashing >= 0.1.0 && < 0.2
-    , hnix-store-core >= 0.1.0 && < 0.3
-    , http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.8
+    , hnix-store-core >= 0.4.0 && < 0.5
+    , hnix-store-remote >= 0.4.0 && < 0.5
+    , http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.7
     , http-client-tls >= 0.3.5 && < 0.4
     , http-types >= 0.12.2 && < 0.13
     , lens-family >= 1.2.2 && < 2.2

src/Nix/Convert.hs

@@ -151,7 +151,7 @@ instance ( Convertible e t f m
     NVStr' ns -> pure $ Just ns
     NVPath' p ->
       Just
-        .   hackyMakeNixStringWithoutContext
+        .   (\s -> principledMakeNixStringWithSingletonContext s (StringContext s DirectPath))
         .   Text.pack
         .   unStorePath
         <$> addPath p

src/Nix/Effects.hs

@@ -7,6 +7,8 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Nix.Effects where
 
@@ -17,24 +19,31 @@ import           Prelude                 hiding ( putStr
 import qualified Prelude
 
 import           Control.Monad.Trans
+import qualified Data.HashSet                  as HS
 import           Data.Text                      ( Text )
 import qualified Data.Text                     as T
-import           Network.HTTP.Client     hiding ( path )
+import qualified Data.Text.Encoding            as T
+import           Network.HTTP.Client     hiding ( path, Proxy )
 import           Network.HTTP.Client.TLS
 import           Network.HTTP.Types
 import           Nix.Expr
-import           Nix.Frames
+import           Nix.Frames              hiding ( Proxy )
 import           Nix.Parser
 import           Nix.Render
 import           Nix.Utils
 import           Nix.Value
 import qualified Paths_hnix
-import qualified System.Directory              as S
 import           System.Environment
 import           System.Exit
+import           System.FilePath                ( takeFileName )
 import qualified System.Info
 import           System.Process
 
+import qualified System.Nix.Hash               as Store
+import qualified System.Nix.Store.Remote       as Store
+import qualified System.Nix.Store.Remote.Types as Store
+import qualified System.Nix.StorePath          as Store
+
 -- | A path into the nix store
 newtype StorePath = StorePath { unStorePath :: FilePath }
 
@@ -226,36 +235,55 @@ print = putStrLn . show
 instance MonadPutStr IO where
   putStr = Prelude.putStr
 
+
+type RecursiveFlag = Bool
+type RepairFlag = Bool
+type StorePathName = Text
+type FilePathFilter m = FilePath -> m Bool
+type StorePathSet = HS.HashSet StorePath
+
 class Monad m => MonadStore m where
-    -- | Import a path into the nix store, and return the resulting path
-    addPath' :: FilePath -> m (Either ErrorCall StorePath)
 
-    -- | Add a file with the given name and contents to the nix store
-    toFile_' :: FilePath -> String -> m (Either ErrorCall StorePath)
+    -- | Copy the contents of a local path to the store.  The resulting store
+    -- path is returned.  Note: This does not support yet support the expected
+    -- `filter` function that allows excluding some files.
+    addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
+    default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
+    addToStore a b c d = lift $ addToStore a b c d
+
+    -- | Like addToStore, but the contents written to the output path is a
+    -- regular file containing the given string.
+    addTextToStore' :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
+    default addTextToStore' :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
+    addTextToStore' a b c d = lift $ addTextToStore' a b c d
+
+parseStoreResult :: Monad m => String -> (Either String a, [Store.Logger]) -> m (Either ErrorCall a)
+parseStoreResult name res = case res of
+  (Left msg, logs) -> return $ Left $ ErrorCall $ "Failed to execute '" ++ name ++ "': " ++ msg ++ "\n" ++ show logs
+  (Right result, _) -> return $ Right result
 
 instance MonadStore IO where
-  addPath' path = do
-    (exitCode, out, _) <- readProcessWithExitCode "nix-store" ["--add", path] ""
-    case exitCode of
-      ExitSuccess -> do
-        let dropTrailingLinefeed p = take (length p - 1) p
-        pure $ Right $ StorePath $ dropTrailingLinefeed out
-      _ ->
-        pure
-          $  Left
-          $  ErrorCall
-          $  "addPath: failed: nix-store --add "
-          ++ show path
 
-  --TODO: Use a temp directory so we don't overwrite anything important
-  toFile_' filepath content = do
-    writeFile filepath content
-    storepath <- addPath' filepath
-    S.removeFile filepath
-    pure storepath
+  addToStore name path recursive repair = case Store.makeStorePathName name of
+    Left err -> return $ Left $ ErrorCall $ "String '" ++ show name ++ "' is not a valid path name: " ++ err
+    Right pathName -> do
+      -- TODO: redesign the filter parameter
+      res <- Store.runStore $ Store.addToStore @'Store.SHA256 pathName path recursive (const False) repair
+      parseStoreResult "addToStore" res >>= \case
+        Left err -> return $ Left err
+        Right storePath -> return $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath storePath
+
+  addTextToStore' name text references repair = do
+    res <- Store.runStore $ Store.addTextToStore name text references repair
+    parseStoreResult "addTextToStore" res >>= \case
+      Left err -> return $ Left err
+      Right path -> return $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath path
+
+addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
+addTextToStore a b c d = either throwError return =<< addTextToStore' a b c d
 
 addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath
-addPath p = either throwError pure =<< addPath' p
+addPath p = either throwError return =<< addToStore (T.pack $ takeFileName p) p True False
 
 toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
-toFile_ p contents = either throwError pure =<< toFile_' p contents
+toFile_ p contents = addTextToStore (T.pack p) (T.pack contents) HS.empty False

src/Nix/Effects/Basic.hs

@@ -8,10 +8,6 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ViewPatterns #-}
 
-{-# OPTIONS_GHC -Wno-missing-signatures #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-
 module Nix.Effects.Basic where
 
 import           Control.Monad
@@ -20,30 +16,24 @@ import           Data.HashMap.Lazy              ( HashMap )
 import qualified Data.HashMap.Lazy             as M
 import           Data.List
 import           Data.List.Split
-import           Data.Maybe                     ( maybeToList )
 import           Data.Text                      ( Text )
 import qualified Data.Text                     as Text
-import           Nix.Atoms
+import           Data.Text.Prettyprint.Doc
 import           Nix.Convert
 import           Nix.Effects
 import           Nix.Exec                       ( MonadNix
-                                                , callFunc
                                                 , evalExprLoc
                                                 , nixInstantiateExpr
                                                 )
 import           Nix.Expr
 import           Nix.Frames
-import           Nix.Normal
 import           Nix.Parser
-import           Nix.Pretty
 import           Nix.Render
 import           Nix.Scope
 import           Nix.String
-import           Nix.String.Coerce
 import           Nix.Utils
 import           Nix.Value
 import           Nix.Value.Monad
-import           Prettyprinter
 import           System.FilePath
 
 #ifdef MIN_VERSION_ghc_datasize
@@ -126,8 +116,8 @@ findPathBy
   -> [NValue t f m]
   -> FilePath
   -> m FilePath
-findPathBy finder l name = do
-  mpath <- foldM go Nothing l
+findPathBy finder ls name = do
+  mpath <- foldM go Nothing ls
   case mpath of
     Nothing ->
       throwError
@@ -235,13 +225,13 @@ findPathM = findPathBy existingPath
     pure $ if exists then Just apath else Nothing
 
 defaultImportPath
-  :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc) m)
+  :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc, b) m)
   => FilePath
   -> m (NValue t f m)
 defaultImportPath path = do
   traceM $ "Importing file " ++ path
   withFrame Info (ErrorCall $ "While importing file " ++ show path) $ do
-    imports <- get
+    imports <- gets fst
     evalExprLoc =<< case M.lookup path imports of
       Just expr -> pure expr
       Nothing   -> do
@@ -252,7 +242,7 @@ defaultImportPath path = do
               $ ErrorCall
               . show $ fillSep ["Parse during import failed:", err]
           Success expr -> do
-            modify (M.insert path expr)
+            modify (\(a, b) -> (M.insert path expr a, b))
             pure expr
 
 defaultPathToDefaultNix :: MonadNix e t f m => FilePath -> m FilePath
@@ -264,38 +254,5 @@ pathToDefaultNixFile p = do
   isDir <- doesDirectoryExist p
   pure $ if isDir then p </> "default.nix" else p
 
-defaultDerivationStrict
-  :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)
-defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
-  nn <- maybe (pure False) (demand ?? fromValue) (M.lookup "__ignoreNulls" s)
-  s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s)
-  v' <- normalForm =<< toValue @(AttrSet (NValue t f m)) @_ @(NValue t f m) s'
-  nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValue v')
- where
-  mapMaybeM :: (a -> m (Maybe b)) -> [a] -> m [b]
-  mapMaybeM op = foldr f (pure [])
-    where f x xs = op x >>= (<$> xs) . (++) . maybeToList
-
-  handleEntry :: Bool -> (Text, NValue t f m) -> m (Maybe (Text, NValue t f m))
-  handleEntry ignoreNulls (k, v) = fmap (k, ) <$> case k of
-      -- The `args' attribute is special: it supplies the command-line
-      -- arguments to the builder.
-      -- TODO This use of coerceToString is probably not right and may
-      -- not have the right arguments.
-    "args"          -> demand v $ fmap Just . coerceNixList
-    "__ignoreNulls" -> pure Nothing
-    _               -> demand v $ \case
-      NVConstant NNull | ignoreNulls -> pure Nothing
-      v'                             -> Just <$> coerceNix v'
-   where
-    coerceNix :: NValue t f m -> m (NValue t f m)
-    coerceNix = toValue <=< coerceToString callFunc CopyToStore CoerceAny
-
-    coerceNixList :: NValue t f m -> m (NValue t f m)
-    coerceNixList v = do
-      xs <- fromValue @[NValue t f m] v
-      ys <- traverse (`demand` coerceNix) xs
-      toValue @[NValue t f m] ys
-
 defaultTraceEffect :: MonadPutStr m => String -> m ()
 defaultTraceEffect = Nix.Effects.putStrLn