{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}

module Distribution.Client.Nix
  ( findNixExpr
  , inNixShell
  , nixInstantiate
  , nixShell
  ) where

import Distribution.Client.Compat.Prelude

import Control.Exception (bracket)
import System.Directory
  ( canonicalizePath
  , createDirectoryIfMissing
  , doesDirectoryExist
  , doesFileExist
  , removeDirectoryRecursive
  , removeFile
  )
import System.Environment (getArgs, getExecutablePath)
import System.FilePath
  ( replaceExtension
  , takeDirectory
  , takeFileName
  , (</>)
  )
import System.IO (IOMode (..), hClose, openFile)
import System.IO.Error (isDoesNotExistError)
import System.Process (showCommandForUser)

import Distribution.Compat.Environment
  ( lookupEnv
  , setEnv
  , unsetEnv
  )

import Distribution.Simple.Program
  ( Program (..)
  , ProgramDb
  , addKnownProgram
  , configureProgram
  , emptyProgramDb
  , getDbProgramOutput
  , runDbProgram
  , simpleProgram
  )
import Distribution.Simple.Setup (fromFlagOrDefault)
import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan, warn)

import Distribution.Client.Config (SavedConfig (..))
import Distribution.Client.GlobalFlags (GlobalFlags (..))

configureOneProgram :: Verbosity -> Program -> IO ProgramDb
configureOneProgram :: Verbosity -> Program -> IO ProgramDb
configureOneProgram Verbosity
verb Program
prog =
  Verbosity -> Program -> ProgramDb -> IO ProgramDb
configureProgram Verbosity
verb Program
prog (Program -> ProgramDb -> ProgramDb
addKnownProgram Program
prog ProgramDb
emptyProgramDb)

touchFile :: FilePath -> IO ()
touchFile :: FilePath -> IO ()
touchFile FilePath
path = do
  IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (FilePath -> IO ()
removeFile FilePath
path) (\IOError
e -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IOError -> Bool
isDoesNotExistError IOError
e) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
path)
  FilePath -> IOMode -> IO Handle
openFile FilePath
path IOMode
WriteMode IO Handle -> (Handle -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> IO ()
hClose

findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath)
findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath)
findNixExpr GlobalFlags
globalFlags SavedConfig
config = do
  -- criteria for deciding to run nix-shell
  let nixEnabled :: Bool
nixEnabled =
        Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault
          Bool
False
          (GlobalFlags -> Flag Bool
globalNix (SavedConfig -> GlobalFlags
savedGlobalFlags SavedConfig
config) Flag Bool -> Flag Bool -> Flag Bool
forall a. Semigroup a => a -> a -> a
<> GlobalFlags -> Flag Bool
globalNix GlobalFlags
globalFlags)

  if Bool
nixEnabled
    then do
      let exprPaths :: [FilePath]
exprPaths = [FilePath
"shell.nix", FilePath
"default.nix"]
      (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist [FilePath]
exprPaths IO [FilePath]
-> ([FilePath] -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
        (FilePath
path : [FilePath]
_) -> Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
path)
    else Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing

-- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell
inFakeNixShell :: IO a -> IO a
inFakeNixShell :: forall a. IO a -> IO a
inFakeNixShell IO a
f =
  IO (Maybe FilePath)
-> (Maybe FilePath -> IO ()) -> (Maybe FilePath -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> FilePath -> IO (Maybe FilePath)
fakeEnv FilePath
"IN_NIX_SHELL" FilePath
"1") (FilePath -> Maybe FilePath -> IO ()
resetEnv FilePath
"IN_NIX_SHELL") (\Maybe FilePath
_ -> IO a
f)
  where
    fakeEnv :: FilePath -> FilePath -> IO (Maybe FilePath)
fakeEnv FilePath
var FilePath
new = do
      Maybe FilePath
old <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
var
      FilePath -> FilePath -> IO ()
setEnv FilePath
var FilePath
new
      Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
old
    resetEnv :: FilePath -> Maybe FilePath -> IO ()
resetEnv FilePath
var = IO () -> (FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> IO ()
unsetEnv FilePath
var) (FilePath -> FilePath -> IO ()
setEnv FilePath
var)

nixInstantiate
  :: Verbosity
  -> FilePath
  -> Bool
  -> GlobalFlags
  -> SavedConfig
  -> IO ()
nixInstantiate :: Verbosity
-> FilePath -> Bool -> GlobalFlags -> SavedConfig -> IO ()
nixInstantiate Verbosity
verb FilePath
dist Bool
force' GlobalFlags
globalFlags SavedConfig
config =
  GlobalFlags -> SavedConfig -> IO (Maybe FilePath)
findNixExpr GlobalFlags
globalFlags SavedConfig
config IO (Maybe FilePath) -> (Maybe FilePath -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe FilePath
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just FilePath
shellNix -> do
      Bool
alreadyInShell <- IO Bool
inNixShell
      FilePath
shellDrv <- FilePath -> FilePath -> IO FilePath
drvPath FilePath
dist FilePath
shellNix
      Bool
instantiated <- FilePath -> IO Bool
doesFileExist FilePath
shellDrv
      -- an extra timestamp file is necessary because the derivation lives in
      -- the store so its mtime is always 1.
      let timestamp :: FilePath
timestamp = FilePath -> FilePath -> FilePath
timestampPath FilePath
dist FilePath
shellNix
      Bool
upToDate <- FilePath -> FilePath -> IO Bool
existsAndIsMoreRecentThan FilePath
timestamp FilePath
shellNix

      let ready :: Bool
ready = Bool
alreadyInShell Bool -> Bool -> Bool
|| (Bool
instantiated Bool -> Bool -> Bool
&& Bool
upToDate Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
force')
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ready (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let prog :: Program
prog = FilePath -> Program
simpleProgram FilePath
"nix-instantiate"
        ProgramDb
progdb <- Verbosity -> Program -> IO ProgramDb
configureOneProgram Verbosity
verb Program
prog

        Verbosity -> FilePath -> IO ()
removeGCRoots Verbosity
verb FilePath
dist
        FilePath -> IO ()
touchFile FilePath
timestamp

        FilePath
_ <-
          IO FilePath -> IO FilePath
forall a. IO a -> IO a
inFakeNixShell
            ( Verbosity -> Program -> ProgramDb -> [FilePath] -> IO FilePath
getDbProgramOutput
                Verbosity
verb
                Program
prog
                ProgramDb
progdb
                [FilePath
"--add-root", FilePath
shellDrv, FilePath
"--indirect", FilePath
shellNix]
            )
        () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

nixShell
  :: Verbosity
  -> FilePath
  -> GlobalFlags
  -> SavedConfig
  -> IO ()
  -- ^ The action to perform inside a nix-shell. This is also the action
  -- that will be performed immediately if Nix is disabled.
  -> IO ()
nixShell :: Verbosity
-> FilePath -> GlobalFlags -> SavedConfig -> IO () -> IO ()
nixShell Verbosity
verb FilePath
dist GlobalFlags
globalFlags SavedConfig
config IO ()
go = do
  Bool
alreadyInShell <- IO Bool
inNixShell

  if Bool
alreadyInShell
    then IO ()
go
    else do
      GlobalFlags -> SavedConfig -> IO (Maybe FilePath)
findNixExpr GlobalFlags
globalFlags SavedConfig
config IO (Maybe FilePath) -> (Maybe FilePath -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe FilePath
Nothing -> IO ()
go
        Just FilePath
shellNix -> do
          -- Nix integration never worked with cabal-install v2 commands ...
          Verbosity -> FilePath -> IO ()
warn Verbosity
verb FilePath
"Nix integration has been deprecated and will be removed in a future release. You can learn more about it here: https://cabal.readthedocs.io/en/latest/nix-integration.html"

          let prog :: Program
prog = FilePath -> Program
simpleProgram FilePath
"nix-shell"
          ProgramDb
progdb <- Verbosity -> Program -> IO ProgramDb
configureOneProgram Verbosity
verb Program
prog

          FilePath
cabal <- IO FilePath
getExecutablePath

          -- alreadyInShell == True in child process
          FilePath -> FilePath -> IO ()
setEnv FilePath
"CABAL_IN_NIX_SHELL" FilePath
"1"

          -- Run cabal with the same arguments inside nix-shell.
          -- When the child process reaches the top of nixShell, it will
          -- detect that it is running inside the shell and fall back
          -- automatically.
          FilePath
shellDrv <- FilePath -> FilePath -> IO FilePath
drvPath FilePath
dist FilePath
shellNix
          [FilePath]
args <- IO [FilePath]
getArgs
          Verbosity -> Program -> ProgramDb -> [FilePath] -> IO ()
runDbProgram
            Verbosity
verb
            Program
prog
            ProgramDb
progdb
            [ FilePath
"--add-root"
            , FilePath -> FilePath
gcrootPath FilePath
dist FilePath -> FilePath -> FilePath
</> FilePath
"result"
            , FilePath
"--indirect"
            , FilePath
shellDrv
            , FilePath
"--run"
            , FilePath -> [FilePath] -> FilePath
showCommandForUser FilePath
cabal [FilePath]
args
            ]

drvPath :: FilePath -> FilePath -> IO FilePath
drvPath :: FilePath -> FilePath -> IO FilePath
drvPath FilePath
dist FilePath
path = do
  -- We do not actually care about canonicity, but makeAbsolute is only
  -- available in newer versions of directory.
  -- We expect the path to be a symlink if it exists, so we do not canonicalize
  -- the entire path because that would dereference the symlink.
  FilePath
distNix <- FilePath -> IO FilePath
canonicalizePath (FilePath
dist FilePath -> FilePath -> FilePath
</> FilePath
"nix")
  -- Nix garbage collector roots must be absolute paths
  FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
distNix FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
replaceExtension (FilePath -> FilePath
takeFileName FilePath
path) FilePath
"drv")

timestampPath :: FilePath -> FilePath -> FilePath
timestampPath :: FilePath -> FilePath -> FilePath
timestampPath FilePath
dist FilePath
path =
  FilePath
dist FilePath -> FilePath -> FilePath
</> FilePath
"nix" FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
replaceExtension (FilePath -> FilePath
takeFileName FilePath
path) FilePath
"drv.timestamp"

gcrootPath :: FilePath -> FilePath
gcrootPath :: FilePath -> FilePath
gcrootPath FilePath
dist = FilePath
dist FilePath -> FilePath -> FilePath
</> FilePath
"nix" FilePath -> FilePath -> FilePath
</> FilePath
"gcroots"

inNixShell :: IO Bool
inNixShell :: IO Bool
inNixShell = Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FilePath -> Bool) -> IO (Maybe FilePath) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"CABAL_IN_NIX_SHELL"

removeGCRoots :: Verbosity -> FilePath -> IO ()
removeGCRoots :: Verbosity -> FilePath -> IO ()
removeGCRoots Verbosity
verb FilePath
dist = do
  let tgt :: FilePath
tgt = FilePath -> FilePath
gcrootPath FilePath
dist
  Bool
exists <- FilePath -> IO Bool
doesDirectoryExist FilePath
tgt
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> FilePath -> IO ()
debug Verbosity
verb (FilePath
"removing Nix gcroots from " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tgt)
    FilePath -> IO ()
removeDirectoryRecursive FilePath
tgt