{-# language AllowAmbiguousTypes #-}
{-# language CPP #-}
{-# language DefaultSignatures #-}
{-# language TypeFamilies #-}
{-# language DataKinds #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language UndecidableInstances #-}
{-# 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}@
{-# language TypeOperators #-}

{-# options_ghc -Wno-orphans #-}


module Nix.Effects where

import           Nix.Prelude             hiding ( putStrLn
                                                , print
                                                )
import qualified Nix.Prelude                   as Prelude
import           GHC.Exception                  ( ErrorCall(ErrorCall) )
import qualified Data.HashSet                  as HS
import qualified Data.Text                     as Text
import           Network.HTTP.Client     hiding ( path, Proxy )
import           Network.HTTP.Client.TLS
import           Network.HTTP.Types
import qualified "cryptonite" Crypto.Hash      as Hash
import           Nix.Utils.Fix1
import           Nix.Expr.Types.Annotated
import           Nix.Frames              hiding ( Proxy )
import           Nix.Parser
import           Nix.Render
import           Nix.Value
import qualified Paths_hnix
import           System.Exit
import qualified System.Info
import           System.Process

import qualified System.Nix.Store.Remote       as Store.Remote
import qualified System.Nix.StorePath          as Store
import qualified System.Nix.Nar                as Store.Nar

-- | A path into the nix store
newtype StorePath = StorePath Path


-- All of the following type classes defer to the underlying 'm'.

-- * @class MonadEffects t f m@

class
  ( MonadFile m
  , MonadStore m
  , MonadPutStr m
  , MonadHttp m
  , MonadEnv m
  , MonadPaths m
  , MonadInstantiate m
  , MonadExec m
  , MonadIntrospect m
  )
  => MonadEffects t f m where

  -- | Determine the absolute path in the current context.
  toAbsolutePath :: Path -> m Path
  findEnvPath :: String -> m Path

  -- | Having an explicit list of sets corresponding to the @NIX_PATH@ and a file path try to find an existing path.
  findPath :: [NValue t f m] -> Path -> m Path

  importPath :: Path -> m (NValue t f m)
  pathToDefaultNix :: Path -> m Path

  derivationStrict :: NValue t f m -> m (NValue t f m)

  --  2021-04-01: for trace, so leaving String here
  traceEffect :: String -> m ()


-- ** Instances

instance
  ( MonadFix1T t m
  , MonadStore m
  )
  => MonadStore (Fix1T t m)
 where
  addToStore :: StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> Fix1T t m (Either ErrorCall StorePath)
addToStore StorePathName
a NarContent
b RecursiveFlag
c RecursiveFlag
d = m (Either ErrorCall StorePath)
-> Fix1T t m (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => m a -> Fix1T t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either ErrorCall StorePath)
 -> Fix1T t m (Either ErrorCall StorePath))
-> m (Either ErrorCall StorePath)
-> Fix1T t m (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore StorePathName
a NarContent
b RecursiveFlag
c RecursiveFlag
d
  addTextToStore' :: StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> Fix1T t m (Either ErrorCall StorePath)
addTextToStore' StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d = m (Either ErrorCall StorePath)
-> Fix1T t m (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => m a -> Fix1T t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either ErrorCall StorePath)
 -> Fix1T t m (Either ErrorCall StorePath))
-> m (Either ErrorCall StorePath)
-> Fix1T t m (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addTextToStore' StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d

-- * @class MonadIntrospect m@

class
  Monad m
  => MonadIntrospect m
 where
  recursiveSize :: a -> m Word
  default recursiveSize :: (MonadTrans t, MonadIntrospect m', m ~ t m') => a -> m Word
  recursiveSize = m' Word -> m Word
m' Word -> t m' Word
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' Word -> m Word) -> (a -> m' Word) -> a -> m Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m' Word
forall a. a -> m' Word
forall (m :: * -> *) a. MonadIntrospect m => a -> m Word
recursiveSize


-- ** Instances

instance MonadIntrospect IO where
  recursiveSize :: forall a. a -> IO Word
recursiveSize =
#ifdef MIN_VERSION_ghc_datasize
    recursiveSize
#else
    IO Word -> a -> IO Word
forall a b. a -> b -> a
const (IO Word -> a -> IO Word) -> IO Word -> a -> IO Word
forall a b. (a -> b) -> a -> b
$ Word -> IO Word
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0
#endif

deriving
  instance
    MonadIntrospect (t (Fix1 t))
    => MonadIntrospect (Fix1 t)

deriving
  instance
    MonadIntrospect (t (Fix1T t m) m)
    => MonadIntrospect (Fix1T t m)


-- * @class MonadExec m@

class
  Monad m
  => MonadExec m where

    exec' :: [Text] -> m (Either ErrorCall NExprLoc)
    default exec' :: (MonadTrans t, MonadExec m', m ~ t m')
                  => [Text] -> m (Either ErrorCall NExprLoc)
    exec' = m' (Either ErrorCall NExprLoc) -> m (Either ErrorCall NExprLoc)
m' (Either ErrorCall NExprLoc) -> t m' (Either ErrorCall NExprLoc)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Either ErrorCall NExprLoc) -> m (Either ErrorCall NExprLoc))
-> ([StorePathName] -> m' (Either ErrorCall NExprLoc))
-> [StorePathName]
-> m (Either ErrorCall NExprLoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StorePathName] -> m' (Either ErrorCall NExprLoc)
forall (m :: * -> *).
MonadExec m =>
[StorePathName] -> m (Either ErrorCall NExprLoc)
exec'


-- ** Instances

instance MonadExec IO where
  exec' :: [StorePathName] -> IO (Either ErrorCall NExprLoc)
exec' = \case
    []            -> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc))
-> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall a b. (a -> b) -> a -> b
$ ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall FilePath
"exec: missing program"
    (StorePathName
prog : [StorePathName]
args) -> do
      (ExitCode
exitCode, FilePath
out, FilePath
_) <- IO (ExitCode, FilePath, FilePath)
-> IO (ExitCode, FilePath, FilePath)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, FilePath, FilePath)
 -> IO (ExitCode, FilePath, FilePath))
-> IO (ExitCode, FilePath, FilePath)
-> IO (ExitCode, FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode (StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString StorePathName
prog) (StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString (StorePathName -> FilePath) -> [StorePathName] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StorePathName]
args) FilePath
forall a. Monoid a => a
mempty
      let
        t :: StorePathName
t    = StorePathName -> StorePathName
Text.strip (StorePathName -> StorePathName) -> StorePathName -> StorePathName
forall a b. (a -> b) -> a -> b
$ FilePath -> StorePathName
forall a. IsString a => FilePath -> a
fromString FilePath
out
        emsg :: StorePathName
emsg = StorePathName
"program[" StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
prog StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
"] args=" StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> [StorePathName] -> StorePathName
forall b a. (Show a, IsString b) => a -> b
show [StorePathName]
args
      case ExitCode
exitCode of
        ExitCode
ExitSuccess ->
          Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc))
-> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall a b. (a -> b) -> a -> b
$
          if StorePathName -> RecursiveFlag
Text.null StorePathName
t
            then ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString (StorePathName -> FilePath) -> StorePathName -> FilePath
forall a b. (a -> b) -> a -> b
$ StorePathName
"exec has no output :" StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
emsg
            else
              (Doc Void -> Either ErrorCall NExprLoc)
-> (NExprLoc -> Either ErrorCall NExprLoc)
-> Either (Doc Void) NExprLoc
-> Either ErrorCall NExprLoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                (\ Doc Void
err -> ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString (StorePathName -> FilePath) -> StorePathName -> FilePath
forall a b. (a -> b) -> a -> b
$ StorePathName
"Error parsing output of exec: " StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> Doc Void -> StorePathName
forall b a. (Show a, IsString b) => a -> b
show Doc Void
err StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
" " StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
emsg)
                NExprLoc -> Either ErrorCall NExprLoc
forall a. a -> Either ErrorCall a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (StorePathName -> Either (Doc Void) NExprLoc
parseNixTextLoc StorePathName
t)
        ExitCode
err -> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc))
-> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall a b. (a -> b) -> a -> b
$ ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString (StorePathName -> FilePath) -> StorePathName -> FilePath
forall a b. (a -> b) -> a -> b
$ StorePathName
"exec  failed: " StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> ExitCode -> StorePathName
forall b a. (Show a, IsString b) => a -> b
show ExitCode
err StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
" " StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
emsg

deriving
  instance
    MonadExec (t (Fix1 t))
    => MonadExec (Fix1 t)

deriving
  instance
    MonadExec (t (Fix1T t m) m)
    => MonadExec (Fix1T t m)


-- * @class MonadInstantiate m@

class
  Monad m
  => MonadInstantiate m where

    instantiateExpr :: Text -> m (Either ErrorCall NExprLoc)
    default instantiateExpr :: (MonadTrans t, MonadInstantiate m', m ~ t m') => Text -> m (Either ErrorCall NExprLoc)
    instantiateExpr = m' (Either ErrorCall NExprLoc) -> m (Either ErrorCall NExprLoc)
m' (Either ErrorCall NExprLoc) -> t m' (Either ErrorCall NExprLoc)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Either ErrorCall NExprLoc) -> m (Either ErrorCall NExprLoc))
-> (StorePathName -> m' (Either ErrorCall NExprLoc))
-> StorePathName
-> m (Either ErrorCall NExprLoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePathName -> m' (Either ErrorCall NExprLoc)
forall (m :: * -> *).
MonadInstantiate m =>
StorePathName -> m (Either ErrorCall NExprLoc)
instantiateExpr


-- ** Instances

instance MonadInstantiate IO where

  instantiateExpr :: StorePathName -> IO (Either ErrorCall NExprLoc)
instantiateExpr StorePathName
expr =
    do
      FilePath -> IO ()
forall (m :: * -> *). Monad m => FilePath -> m ()
traceM (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"Executing: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [StorePathName] -> FilePath
forall b a. (Show a, IsString b) => a -> b
show [StorePathName
"nix-instantiate", StorePathName
"--eval", StorePathName
"--expr ", StorePathName
expr]

      (ExitCode
exitCode, FilePath
out, FilePath
err) <-
        FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode
          FilePath
"nix-instantiate"
          [FilePath
"--eval", FilePath
"--expr", StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString StorePathName
expr]
          FilePath
forall a. Monoid a => a
mempty

      pure $
        case ExitCode
exitCode of
          ExitCode
ExitSuccess ->
            (Doc Void -> Either ErrorCall NExprLoc)
-> (NExprLoc -> Either ErrorCall NExprLoc)
-> Either (Doc Void) NExprLoc
-> Either ErrorCall NExprLoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
              (\ Doc Void
e -> ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath
"Error parsing output of nix-instantiate: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Doc Void -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Doc Void
e)
              NExprLoc -> Either ErrorCall NExprLoc
forall a. a -> Either ErrorCall a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              (StorePathName -> Either (Doc Void) NExprLoc
parseNixTextLoc (StorePathName -> Either (Doc Void) NExprLoc)
-> StorePathName -> Either (Doc Void) NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> StorePathName
forall a. IsString a => FilePath -> a
fromString FilePath
out)
          ExitCode
status -> ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath
"nix-instantiate failed: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ExitCode -> FilePath
forall b a. (Show a, IsString b) => a -> b
show ExitCode
status FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
": " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err

deriving
  instance
    MonadInstantiate (t (Fix1 t))
    => MonadInstantiate (Fix1 t)

deriving
  instance
    MonadInstantiate (t (Fix1T t m) m)
    => MonadInstantiate (Fix1T t m)


-- * @class MonadEnv m@

class
  Monad m
  => MonadEnv m where

  getEnvVar :: Text -> m (Maybe Text)
  default getEnvVar :: (MonadTrans t, MonadEnv m', m ~ t m') => Text -> m (Maybe Text)
  getEnvVar = m' (Maybe StorePathName) -> m (Maybe StorePathName)
m' (Maybe StorePathName) -> t m' (Maybe StorePathName)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Maybe StorePathName) -> m (Maybe StorePathName))
-> (StorePathName -> m' (Maybe StorePathName))
-> StorePathName
-> m (Maybe StorePathName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePathName -> m' (Maybe StorePathName)
forall (m :: * -> *).
MonadEnv m =>
StorePathName -> m (Maybe StorePathName)
getEnvVar

  getCurrentSystemOS :: m Text
  default getCurrentSystemOS :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text
  getCurrentSystemOS = m' StorePathName -> t m' StorePathName
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' StorePathName
forall (m :: * -> *). MonadEnv m => m StorePathName
getCurrentSystemOS

  getCurrentSystemArch :: m Text
  default getCurrentSystemArch :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text
  getCurrentSystemArch = m' StorePathName -> t m' StorePathName
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' StorePathName
forall (m :: * -> *). MonadEnv m => m StorePathName
getCurrentSystemArch


-- ** Instances

instance MonadEnv IO where
  getEnvVar :: StorePathName -> IO (Maybe StorePathName)
getEnvVar            = (FilePath -> StorePathName)
-> IO (Maybe FilePath) -> IO (Maybe StorePathName)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
(<<$>>) FilePath -> StorePathName
forall a. IsString a => FilePath -> a
fromString (IO (Maybe FilePath) -> IO (Maybe StorePathName))
-> (StorePathName -> IO (Maybe FilePath))
-> StorePathName
-> IO (Maybe StorePathName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Maybe FilePath)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
lookupEnv (FilePath -> IO (Maybe FilePath))
-> (StorePathName -> FilePath)
-> StorePathName
-> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString

  getCurrentSystemOS :: IO StorePathName
getCurrentSystemOS   = StorePathName -> IO StorePathName
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorePathName -> IO StorePathName)
-> StorePathName -> IO StorePathName
forall a b. (a -> b) -> a -> b
$ FilePath -> StorePathName
forall a. IsString a => FilePath -> a
fromString FilePath
System.Info.os

  -- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
  getCurrentSystemArch :: IO StorePathName
getCurrentSystemArch = StorePathName -> IO StorePathName
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorePathName -> IO StorePathName)
-> StorePathName -> IO StorePathName
forall a b. (a -> b) -> a -> b
$ FilePath -> StorePathName
forall a. IsString a => FilePath -> a
fromString (FilePath -> StorePathName) -> FilePath -> StorePathName
forall a b. (a -> b) -> a -> b
$ case FilePath
System.Info.arch of
    FilePath
"i386" -> FilePath
"i686"
    FilePath
arch   -> FilePath
arch

deriving
  instance
    MonadEnv (t (Fix1 t))
    => MonadEnv (Fix1 t)

deriving
  instance
    MonadEnv (t (Fix1T t m) m)
    => MonadEnv (Fix1T t m)


-- * @class MonadPaths m@

class
  Monad m
  => MonadPaths m where
  getDataDir :: m Path
  default getDataDir :: (MonadTrans t, MonadPaths m', m ~ t m') => m Path
  getDataDir = m' Path -> t m' Path
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' Path
forall (m :: * -> *). MonadPaths m => m Path
getDataDir


-- ** Instances

instance MonadPaths IO where
  getDataDir :: IO Path
getDataDir = IO FilePath -> IO Path
forall a b. Coercible a b => a -> b
coerce IO FilePath
Paths_hnix.getDataDir

deriving
  instance
    MonadPaths (t (Fix1 t))
    => MonadPaths (Fix1 t)

deriving
  instance
    MonadPaths (t (Fix1T t m) m)
    => MonadPaths (Fix1T t m)


-- * @class MonadHttp m@

class
  Monad m
  => MonadHttp m where

  getURL :: Text -> m (Either ErrorCall StorePath)
  default getURL :: (MonadTrans t, MonadHttp m', m ~ t m') => Text -> m (Either ErrorCall StorePath)
  getURL = m' (Either ErrorCall StorePath) -> m (Either ErrorCall StorePath)
m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Either ErrorCall StorePath) -> m (Either ErrorCall StorePath))
-> (StorePathName -> m' (Either ErrorCall StorePath))
-> StorePathName
-> m (Either ErrorCall StorePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePathName -> m' (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadHttp m =>
StorePathName -> m (Either ErrorCall StorePath)
getURL

baseNameOf :: Text -> Text
baseNameOf :: StorePathName -> StorePathName
baseNameOf StorePathName
a = (Char -> RecursiveFlag) -> StorePathName -> StorePathName
Text.takeWhileEnd (Char -> Char -> RecursiveFlag
forall a. Eq a => a -> a -> RecursiveFlag
/=Char
'/') (StorePathName -> StorePathName) -> StorePathName -> StorePathName
forall a b. (a -> b) -> a -> b
$ (Char -> RecursiveFlag) -> StorePathName -> StorePathName
Text.dropWhileEnd (Char -> Char -> RecursiveFlag
forall a. Eq a => a -> a -> RecursiveFlag
==Char
'/') StorePathName
a

-- conversion from Store.StorePath to Effects.StorePath, different type with the same name.
toStorePath :: Store.StorePath -> StorePath
toStorePath :: StorePath -> StorePath
toStorePath = Path -> StorePath
StorePath (Path -> StorePath)
-> (StorePath -> Path) -> StorePath -> StorePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Path
forall a b. Coercible a b => a -> b
coerce (FilePath -> Path) -> (StorePath -> FilePath) -> StorePath -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 @FilePath @ByteString (ByteString -> FilePath)
-> (StorePath -> ByteString) -> StorePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> ByteString
Store.storePathToRawFilePath

-- ** Instances

instance MonadHttp IO where
  getURL :: StorePathName -> IO (Either ErrorCall StorePath)
getURL StorePathName
url =
    do
      let urlstr :: FilePath
urlstr = StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString StorePathName
url
      FilePath -> IO ()
forall (m :: * -> *). Monad m => FilePath -> m ()
traceM (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"fetching HTTP URL: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
urlstr
      Request
req     <- FilePath -> IO Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest FilePath
urlstr
      Manager
manager <-
        IO Manager -> IO Manager -> RecursiveFlag -> IO Manager
forall a. a -> a -> RecursiveFlag -> a
bool
          (ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings)
          IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
          (Request -> RecursiveFlag
secure Request
req)
      Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs (Request
req { method = "GET" }) Manager
manager
      let status :: Int
status = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response
      let body :: ByteString
body = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response
      -- let digest::Hash.Digest Hash.SHA256 = Hash.hash $ (B.concat . BL.toChunks) body
      let name :: StorePathName
name = StorePathName -> StorePathName
baseNameOf StorePathName
url
      IO (Either ErrorCall StorePath)
-> IO (Either ErrorCall StorePath)
-> RecursiveFlag
-> IO (Either ErrorCall StorePath)
forall a. a -> a -> RecursiveFlag -> a
bool
        (Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall StorePath -> IO (Either ErrorCall StorePath))
-> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ ErrorCall -> Either ErrorCall StorePath
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall StorePath)
-> ErrorCall -> Either ErrorCall StorePath
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath
"fail, got " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
status FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" when fetching url = " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
urlstr)
        -- using addTextToStore' result in different hash from the addToStore.
        -- see https://github.com/haskell-nix/hnix/pull/1051#issuecomment-1031380804
        (StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> IO (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore StorePathName
name (ByteString -> NarContent
NarText (ByteString -> NarContent) -> ByteString -> NarContent
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict ByteString
body) RecursiveFlag
False RecursiveFlag
False)
        (Int
status Int -> Int -> RecursiveFlag
forall a. Eq a => a -> a -> RecursiveFlag
== Int
200)


deriving
  instance
    MonadHttp (t (Fix1 t))
    => MonadHttp (Fix1 t)

deriving
  instance
    MonadHttp (t (Fix1T t m) m)
    => MonadHttp (Fix1T t m)


-- * @class MonadPutStr m@

class
  (Monad m, MonadIO m)
  => MonadPutStr m where

  --TODO: Should this be used *only* when the Nix to be evaluated invokes a
  --`trace` operation?
  --  2021-04-01: Due to trace operation here, leaving it as String.
  putStr :: String -> m ()
  default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m ()
  putStr = m' () -> m ()
m' () -> t m' ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' () -> m ()) -> (FilePath -> m' ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
Prelude.putStr


-- ** Instances

instance MonadPutStr IO where
  putStr :: FilePath -> IO ()
putStr = FilePath -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
Prelude.putStr

deriving
  instance
    MonadPutStr (t (Fix1 t))
    => MonadPutStr (Fix1 t)

deriving
  instance
    MonadPutStr (t (Fix1T t m) m)
    => MonadPutStr (Fix1T t m)


-- ** Functions

putStrLn :: MonadPutStr m => String -> m ()
putStrLn :: forall (m :: * -> *). MonadPutStr m => FilePath -> m ()
putStrLn = FilePath -> m ()
forall (m :: * -> *). MonadPutStr m => FilePath -> m ()
Nix.Effects.putStr (FilePath -> m ()) -> (FilePath -> FilePath) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n")

print :: (MonadPutStr m, Show a) => a -> m ()
print :: forall (m :: * -> *) a. (MonadPutStr m, Show a) => a -> m ()
print = FilePath -> m ()
forall (m :: * -> *). MonadPutStr m => FilePath -> m ()
putStrLn (FilePath -> m ()) -> (a -> FilePath) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall b a. (Show a, IsString b) => a -> b
show

-- * Store effects

-- ** Data type synonyms

type RecursiveFlag = Bool
type RepairFlag = Bool
type StorePathName = Text
type PathFilter m = Path -> m Bool
type StorePathSet = HS.HashSet StorePath


-- ** @class MonadStore m@

data NarContent = NarFile Path | NarText ByteString
-- | convert NarContent to NarSource needed in the store API
toNarSource :: MonadIO m => NarContent -> Store.Nar.NarSource m
toNarSource :: forall (m :: * -> *). MonadIO m => NarContent -> NarSource m
toNarSource (NarFile Path
path) = FilePath -> NarSource m
forall (m :: * -> *). MonadIO m => FilePath -> NarSource m
Store.Nar.dumpPath (FilePath -> NarSource m) -> FilePath -> NarSource m
forall a b. (a -> b) -> a -> b
$ Path -> FilePath
forall a b. Coercible a b => a -> b
coerce Path
path
toNarSource (NarText ByteString
text) = ByteString -> NarSource m
forall (m :: * -> *). MonadIO m => ByteString -> NarSource m
Store.Nar.dumpString ByteString
text

class
  Monad m
  => MonadStore m where

  -- | Copy the contents of a local path(Or pure text) 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 -> NarContent -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
  default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> NarContent -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
  addToStore StorePathName
a NarContent
b RecursiveFlag
c RecursiveFlag
d = m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Either ErrorCall StorePath)
 -> t m' (Either ErrorCall StorePath))
-> m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m' (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore StorePathName
a NarContent
b RecursiveFlag
c RecursiveFlag
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' StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d = m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Either ErrorCall StorePath)
 -> t m' (Either ErrorCall StorePath))
-> m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m' (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addTextToStore' StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d


-- *** Instances

instance MonadStore IO where

  addToStore :: StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> IO (Either ErrorCall StorePath)
addToStore StorePathName
name NarContent
content RecursiveFlag
recursive RecursiveFlag
repair =
    (FilePath -> IO (Either ErrorCall StorePath))
-> (StorePathName -> IO (Either ErrorCall StorePath))
-> Either FilePath StorePathName
-> IO (Either ErrorCall StorePath)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (\ FilePath
err -> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall StorePath -> IO (Either ErrorCall StorePath))
-> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ ErrorCall -> Either ErrorCall StorePath
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall StorePath)
-> ErrorCall -> Either ErrorCall StorePath
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath
"String '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> StorePathName -> FilePath
forall b a. (Show a, IsString b) => a -> b
show StorePathName
name FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' is not a valid path name: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err)
      (\ StorePathName
pathName ->
        do
          (Either FilePath StorePath, [Logger])
res <- MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a. MonadStore a -> IO (Either FilePath a, [Logger])
Store.Remote.runStore (MonadStore StorePath -> IO (Either FilePath StorePath, [Logger]))
-> MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a b. (a -> b) -> a -> b
$ forall a.
NamedAlgo a =>
StorePathName
-> NarSource MonadStore
-> RecursiveFlag
-> RecursiveFlag
-> MonadStore StorePath
Store.Remote.addToStore @Hash.SHA256 StorePathName
pathName (NarContent -> NarSource MonadStore
forall (m :: * -> *). MonadIO m => NarContent -> NarSource m
toNarSource NarContent
content) RecursiveFlag
recursive RecursiveFlag
repair
          (ErrorCall -> Either ErrorCall StorePath)
-> (StorePath -> Either ErrorCall StorePath)
-> Either ErrorCall StorePath
-> Either ErrorCall StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            ErrorCall -> Either ErrorCall StorePath
forall a b. a -> Either a b
Left -- err
            (StorePath -> Either ErrorCall StorePath
forall a. a -> Either ErrorCall a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorePath -> Either ErrorCall StorePath)
-> (StorePath -> StorePath)
-> StorePath
-> Either ErrorCall StorePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> StorePath
toStorePath) -- store path
            (Either ErrorCall StorePath -> Either ErrorCall StorePath)
-> IO (Either ErrorCall StorePath)
-> IO (Either ErrorCall StorePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StorePathName
-> (Either FilePath StorePath, [Logger])
-> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a.
Monad m =>
StorePathName
-> (Either FilePath a, [Logger]) -> m (Either ErrorCall a)
parseStoreResult StorePathName
"addToStore" (Either FilePath StorePath, [Logger])
res
      )
      (StorePathName -> Either FilePath StorePathName
Store.makeStorePathName StorePathName
name)

  addTextToStore' :: StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> IO (Either ErrorCall StorePath)
addTextToStore' StorePathName
name StorePathName
text StorePathSet
references RecursiveFlag
repair =
    do
      (Either FilePath StorePath, [Logger])
res <- MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a. MonadStore a -> IO (Either FilePath a, [Logger])
Store.Remote.runStore (MonadStore StorePath -> IO (Either FilePath StorePath, [Logger]))
-> MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a b. (a -> b) -> a -> b
$ StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> MonadStore StorePath
Store.Remote.addTextToStore StorePathName
name StorePathName
text StorePathSet
references RecursiveFlag
repair
      (ErrorCall -> Either ErrorCall StorePath)
-> (StorePath -> Either ErrorCall StorePath)
-> Either ErrorCall StorePath
-> Either ErrorCall StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        ErrorCall -> Either ErrorCall StorePath
forall a b. a -> Either a b
Left -- err
        (StorePath -> Either ErrorCall StorePath
forall a. a -> Either ErrorCall a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorePath -> Either ErrorCall StorePath)
-> (StorePath -> StorePath)
-> StorePath
-> Either ErrorCall StorePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> StorePath
toStorePath) -- path
        (Either ErrorCall StorePath -> Either ErrorCall StorePath)
-> IO (Either ErrorCall StorePath)
-> IO (Either ErrorCall StorePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StorePathName
-> (Either FilePath StorePath, [Logger])
-> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a.
Monad m =>
StorePathName
-> (Either FilePath a, [Logger]) -> m (Either ErrorCall a)
parseStoreResult StorePathName
"addTextToStore" (Either FilePath StorePath, [Logger])
res


-- ** Functions

parseStoreResult :: Monad m => Text -> (Either String a, [Store.Remote.Logger]) -> m (Either ErrorCall a)
parseStoreResult :: forall (m :: * -> *) a.
Monad m =>
StorePathName
-> (Either FilePath a, [Logger]) -> m (Either ErrorCall a)
parseStoreResult StorePathName
name (Either FilePath a
res, [Logger]
logs) =
  Either ErrorCall a -> m (Either ErrorCall a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall a -> m (Either ErrorCall a))
-> Either ErrorCall a -> m (Either ErrorCall a)
forall a b. (a -> b) -> a -> b
$
    (FilePath -> Either ErrorCall a)
-> (a -> Either ErrorCall a)
-> Either FilePath a
-> Either ErrorCall a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (\ FilePath
msg -> ErrorCall -> Either ErrorCall a
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall a)
-> ErrorCall -> Either ErrorCall a
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to execute '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString StorePathName
name FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"': " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
msg FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Logger] -> FilePath
forall b a. (Show a, IsString b) => a -> b
show [Logger]
logs)
      a -> Either ErrorCall a
forall a. a -> Either ErrorCall a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      Either FilePath a
res

addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
addTextToStore :: forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
StorePathName
-> StorePathName -> StorePathSet -> RecursiveFlag -> m StorePath
addTextToStore StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d =
  (ErrorCall -> m StorePath)
-> (StorePath -> m StorePath)
-> Either ErrorCall StorePath
-> m StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    ErrorCall -> m StorePath
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError
    StorePath -> m StorePath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either ErrorCall StorePath -> m StorePath)
-> m (Either ErrorCall StorePath) -> m StorePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addTextToStore' StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d

--  2021-10-30: NOTE: Misleading name, please rename.
-- | Add @Path@ into the Nix Store
addPath :: (Framed e m, MonadStore m) => Path -> m StorePath
addPath :: forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
Path -> m StorePath
addPath Path
p =
  (ErrorCall -> m StorePath)
-> (StorePath -> m StorePath)
-> Either ErrorCall StorePath
-> m StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    ErrorCall -> m StorePath
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError
    StorePath -> m StorePath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either ErrorCall StorePath -> m StorePath)
-> m (Either ErrorCall StorePath) -> m StorePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore (FilePath -> StorePathName
forall a. IsString a => FilePath -> a
fromString (FilePath -> StorePathName) -> FilePath -> StorePathName
forall a b. (a -> b) -> a -> b
$ (Path -> Path) -> Path -> FilePath
forall a b. Coercible a b => a -> b
coerce Path -> Path
takeFileName Path
p) (Path -> NarContent
NarFile Path
p) RecursiveFlag
True RecursiveFlag
False

toFile_ :: (Framed e m, MonadStore m) => Path -> Text -> m StorePath
toFile_ :: forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
Path -> StorePathName -> m StorePath
toFile_ Path
p StorePathName
contents = StorePathName
-> StorePathName -> StorePathSet -> RecursiveFlag -> m StorePath
forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
StorePathName
-> StorePathName -> StorePathSet -> RecursiveFlag -> m StorePath
addTextToStore (FilePath -> StorePathName
forall a. IsString a => FilePath -> a
fromString (FilePath -> StorePathName) -> FilePath -> StorePathName
forall a b. (a -> b) -> a -> b
$ Path -> FilePath
forall a b. Coercible a b => a -> b
coerce Path
p) StorePathName
contents StorePathSet
forall a. Monoid a => a
mempty RecursiveFlag
False