{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Run commands in a nix-shell
module Stack.Nix
  (nixCmdName
  ,nixHelpOptName
  ,runShellAndExit
  ) where

import           Stack.Prelude
import qualified Data.Text as T
import           Data.Version (showVersion)
import           Path.IO
import qualified Paths_stack as Meta
import           Stack.Config (getInContainer, withBuildConfig)
import           Stack.Config.Nix (nixCompiler)
import           Stack.Constants (platformVariantEnvVar,inNixShellEnvVar,inContainerEnvVar)
import           Stack.Types.Config
import           Stack.Types.Docker
import           Stack.Types.Nix
import           System.Environment (getArgs,getExecutablePath,lookupEnv)
import qualified System.FilePath  as F
import           RIO.Process (processContextL, exec)

runShellAndExit :: RIO Config void
runShellAndExit :: RIO Config void
runShellAndExit = do
   Bool
inContainer <- RIO Config Bool
forall (m :: * -> *). MonadIO m => m Bool
getInContainer -- TODO we can probably assert that this is False based on Stack.Runners now
   [String]
origArgs <- IO [String] -> RIO Config [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
getArgs
   let args :: [String]
args | Bool
inContainer = [String]
origArgs  -- internal-re-exec version already passed
              -- first stack when restarting in the container
            | Bool
otherwise =
                ("--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reExecArgName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
Meta.version) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
origArgs
   String
exePath <- IO String -> RIO Config String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getExecutablePath
   Config
config <- Getting Config Config Config -> RIO Config Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config Config Config
forall env. HasConfig env => Lens' env Config
configL
   ProcessContext
envOverride <- Getting ProcessContext Config ProcessContext
-> RIO Config ProcessContext
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProcessContext Config ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
   (Config -> Config) -> RIO Config void -> RIO Config void
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Config Config ProcessContext ProcessContext
-> ProcessContext -> Config -> Config
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Config Config ProcessContext ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
processContextL ProcessContext
envOverride) (RIO Config void -> RIO Config void)
-> RIO Config void -> RIO Config void
forall a b. (a -> b) -> a -> b
$ do
     let cmnd :: String
cmnd = String -> String
escape String
exePath
         args' :: [String]
args' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
escape [String]
args

     Maybe (Path Abs File)
mshellFile <- case Config -> Maybe (Path Abs Dir)
configProjectRoot Config
config of
         Just projectRoot :: Path Abs Dir
projectRoot ->
             (String -> RIO Config (Path Abs File))
-> Maybe String -> RIO Config (Maybe (Path Abs File))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Path Abs Dir -> String -> RIO Config (Path Abs File)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs File)
resolveFile Path Abs Dir
projectRoot) (Maybe String -> RIO Config (Maybe (Path Abs File)))
-> Maybe String -> RIO Config (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ NixOpts -> Maybe String
nixInitFile (Config -> NixOpts
configNix Config
config)
         Nothing -> Maybe (Path Abs File) -> RIO Config (Maybe (Path Abs File))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing

     -- This will never result in double loading the build config, since:
     --
     -- 1. This function explicitly takes a Config, not a HasConfig
     --
     -- 2. This function ends up exiting before running other code
     -- (thus the void return type)
     WantedCompiler
compilerVersion <- RIO BuildConfig WantedCompiler -> RIO Config WantedCompiler
forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig (RIO BuildConfig WantedCompiler -> RIO Config WantedCompiler)
-> RIO BuildConfig WantedCompiler -> RIO Config WantedCompiler
forall a b. (a -> b) -> a -> b
$ Getting WantedCompiler BuildConfig WantedCompiler
-> RIO BuildConfig WantedCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting WantedCompiler BuildConfig WantedCompiler
forall s r. HasBuildConfig s => Getting r s WantedCompiler
wantedCompilerVersionL

     Text
ghc <- (StringException -> RIO Config Text)
-> (Text -> RIO Config Text)
-> Either StringException Text
-> RIO Config Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either StringException -> RIO Config Text
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO Text -> RIO Config Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Either StringException Text -> RIO Config Text)
-> Either StringException Text -> RIO Config Text
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either StringException Text
nixCompiler WantedCompiler
compilerVersion
     let pkgsInConfig :: [Text]
pkgsInConfig = NixOpts -> [Text]
nixPackages (Config -> NixOpts
configNix Config
config)
         pkgs :: [Text]
pkgs = [Text]
pkgsInConfig [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
ghc, "git", "gcc", "gmp"]
         pkgsStr :: Text
pkgsStr = "[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate " " [Text]
pkgs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "]"
         pureShell :: Bool
pureShell = NixOpts -> Bool
nixPureShell (Config -> NixOpts
configNix Config
config)
         addGCRoots :: Bool
addGCRoots = NixOpts -> Bool
nixAddGCRoots (Config -> NixOpts
configNix Config
config)
         nixopts :: [String]
nixopts = case Maybe (Path Abs File)
mshellFile of
           Just fp :: Path Abs File
fp -> [Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
fp, "--arg", "ghc"
                      ,"with (import <nixpkgs> {}); " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
ghc]
           Nothing -> ["-E", Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
                              ["with (import <nixpkgs> {}); "
                              ,"let inputs = ",Text
pkgsStr,"; "
                              ,    "libPath = lib.makeLibraryPath inputs; "
                              ,    "stackExtraArgs = lib.concatMap (pkg: "
                              ,    "[ ''--extra-lib-dirs=${lib.getLib pkg}/lib'' "
                              ,    "  ''--extra-include-dirs=${lib.getDev pkg}/include'' ]"
                              ,    ") inputs; in "
                              ,"runCommand ''myEnv'' { "
                              ,"buildInputs = lib.optional stdenv.isLinux glibcLocales ++ inputs; "
                              ,String -> Text
T.pack String
platformVariantEnvVar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "=''nix''; "
                              ,String -> Text
T.pack String
inNixShellEnvVar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "=1; "
                              ,if Bool
inContainer
                                  -- If shell is pure, this env var would not
                                  -- be seen by stack inside nix
                                  then String -> Text
T.pack String
inContainerEnvVar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "=1; "
                                  else ""
                              ,"LD_LIBRARY_PATH = libPath;"  -- LD_LIBRARY_PATH is set because for now it's
                               -- needed by builds using Template Haskell
                              ,"STACK_IN_NIX_EXTRA_ARGS = stackExtraArgs; "
                               -- overriding default locale so Unicode output using base won't be broken
                              ,"LANG=\"en_US.UTF-8\";"
                              ,"} \"\""]]
                    -- glibcLocales is necessary on Linux to avoid warnings about GHC being incapable to set the locale.
         fullArgs :: [String]
fullArgs = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [if Bool
pureShell then ["--pure"] else []
                           ,if Bool
addGCRoots then ["--indirect", "--add-root"
                                               ,Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath (Config -> Path Rel Dir
configWorkDir Config
config)
                                                String -> String -> String
F.</> "nix-gc-symlinks" String -> String -> String
F.</> "gc-root"] else []
                           ,(Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack (NixOpts -> [Text]
nixShellOptions (Config -> NixOpts
configNix Config
config))
                           ,[String]
nixopts
                           ,["--run", [String] -> String
unwords (String
cmndString -> [String] -> [String]
forall a. a -> [a] -> [a]
:"$STACK_IN_NIX_EXTRA_ARGS"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args')]
                           ]
                           -- Using --run instead of --command so we cannot
                           -- end up in the nix-shell if stack build is Ctrl-C'd
     Maybe String
pathVar <- IO (Maybe String) -> RIO Config (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> RIO Config (Maybe String))
-> IO (Maybe String) -> RIO Config (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv "PATH"
     Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO Config ()) -> Utf8Builder -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ "PATH is: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Maybe String -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Maybe String
pathVar
     Utf8Builder -> RIO Config ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO Config ()) -> Utf8Builder -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
       "Using a nix-shell environment " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (case Maybe (Path Abs File)
mshellFile of
            Just path :: Path Abs File
path -> "from file: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path)
            Nothing -> "with nix packages: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> [Text] -> Text
T.intercalate ", " [Text]
pkgs))
     String -> [String] -> RIO Config void
forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec "nix-shell" [String]
fullArgs

-- | Shell-escape quotes inside the string and enclose it in quotes.
escape :: String -> String
escape :: String -> String
escape str :: String
str = "'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> String -> String) -> String -> String -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\c :: Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' then
                                   ("'\"'\"'"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
                                 else (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:)) "" String
str
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'"

-- | Command-line argument for "nix"
nixCmdName :: String
nixCmdName :: String
nixCmdName = "nix"

nixHelpOptName :: String
nixHelpOptName :: String
nixHelpOptName = String
nixCmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-help"

-- | Exceptions thrown by "Stack.Nix".
data StackNixException
  = CannotDetermineProjectRoot
    -- ^ Can't determine the project root (location of the shell file if any).
  deriving (Typeable)

instance Exception StackNixException

instance Show StackNixException where
  show :: StackNixException -> String
show CannotDetermineProjectRoot =
    "Cannot determine project root directory."