Implement derivationStrict primOp

Author: layus

hnix.cabal

@@ -341,6 +341,7 @@ library
       Nix.Convert
       Nix.Effects
       Nix.Effects.Basic
+      Nix.Effects.Derivation
       Nix.Eval
       Nix.Exec
       Nix.Expr
@@ -401,8 +402,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.3.0 && < 0.4
+    , hnix-store-remote >= 0.2.0 && < 0.3
+    , 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/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,54 @@ 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)
+    -- | Add a path to the store, with bells and whistles
+    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
+
+    -- | Add a nar (action) to the store
+    -- addToStore' :: StorePathName -> IO Nar -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
+
+    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
@@ -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