{-# LANGUAGE RecordWildCards #-}

-- | cabal-install CLI command: configure
module Distribution.Client.CmdConfigure
  ( configureCommand
  , configureAction
  , configureAction'
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import System.Directory
import System.FilePath

import Distribution.Client.ProjectConfig
  ( readProjectLocalExtraConfig
  , writeProjectLocalExtraConfig
  )
import Distribution.Client.ProjectFlags
  ( removeIgnoreProjectOption
  )
import Distribution.Client.ProjectOrchestration
import Distribution.Simple.Flag
import Distribution.Simple.Setup (CommonSetupFlags (..))

import Distribution.Client.NixStyleOptions
  ( NixStyleFlags (..)
  , defaultNixStyleFlags
  , nixStyleOptions
  )
import Distribution.Client.Setup
  ( ConfigExFlags (..)
  , ConfigFlags (..)
  , GlobalFlags
  )
import Distribution.Verbosity
  ( normal
  )

import Distribution.Simple.Command
  ( CommandUI (..)
  , usageAlternatives
  )
import Distribution.Simple.Utils
  ( dieWithException
  , notice
  , wrapText
  )

import Distribution.Client.DistDirLayout
  ( DistDirLayout (..)
  )
import Distribution.Client.Errors
import Distribution.Client.HttpUtils
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.RebuildMonad (runRebuild)
import Distribution.Types.CondTree
  ( CondTree (..)
  )
import Distribution.Utils.NubList
  ( fromNubList
  )

configureCommand :: CommandUI (NixStyleFlags ())
configureCommand :: CommandUI (NixStyleFlags ())
configureCommand =
  CommandUI
    { commandName :: String
commandName = String
"v2-configure"
    , commandSynopsis :: String
commandSynopsis = String
"Add extra project configuration."
    , commandUsage :: String -> String
commandUsage = String -> [String] -> String -> String
usageAlternatives String
"v2-configure" [String
"[FLAGS]"]
    , commandDescription :: Maybe (String -> String)
commandDescription = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
_ ->
        String -> String
wrapText (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
          String
"Adjust how the project is built by setting additional package flags "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"and other flags.\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"The configuration options are written to the 'cabal.project.local' "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"file (or '$project_file.local', if '--project-file' is specified) "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"which extends the configuration from the 'cabal.project' file "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(if any). This combination is used as the project configuration for "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"all other commands (such as 'v2-build', 'v2-repl' etc) though it "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"can be extended/overridden on a per-command basis.\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"The v2-configure command also checks that the project configuration "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"will work. In particular it checks that there is a consistent set of "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"dependencies for the project as a whole.\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"The 'cabal.project.local' file persists across 'v2-clean' but is "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"overwritten on the next use of the 'v2-configure' command. The "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"intention is that the 'cabal.project' file should be kept in source "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"control but the 'cabal.project.local' should not.\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"It is never necessary to use the 'v2-configure' command. It is "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"merely a convenience in cases where you do not want to specify flags "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"to 'v2-build' (and other commands) every time and yet do not want "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"to alter the 'cabal.project' persistently."
    , commandNotes :: Maybe (String -> String)
commandNotes = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
pname ->
        String
"Examples:\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-configure --with-compiler ghc-7.10.3\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Adjust the project configuration to use the given compiler\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    program and check the resulting configuration works.\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-configure\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Reset the local configuration to empty. To check that the\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    project configuration works, use 'cabal build'.\n"
    , commandDefaultFlags :: NixStyleFlags ()
commandDefaultFlags = () -> NixStyleFlags ()
forall a. a -> NixStyleFlags a
defaultNixStyleFlags ()
    , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
commandOptions =
        [OptionField (NixStyleFlags ())]
-> [OptionField (NixStyleFlags ())]
forall a. [OptionField a] -> [OptionField a]
removeIgnoreProjectOption
          ([OptionField (NixStyleFlags ())]
 -> [OptionField (NixStyleFlags ())])
-> (ShowOrParseArgs -> [OptionField (NixStyleFlags ())])
-> ShowOrParseArgs
-> [OptionField (NixStyleFlags ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowOrParseArgs -> [OptionField ()])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ([OptionField ()] -> ShowOrParseArgs -> [OptionField ()]
forall a b. a -> b -> a
const [])
    }

-- | To a first approximation, the @configure@ just runs the first phase of
-- the @build@ command where we bring the install plan up to date (thus
-- checking that it's possible).
--
-- The only difference is that @configure@ also allows the user to specify
-- some extra config flags which we save in the file @cabal.project.local@.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
configureAction flags :: NixStyleFlags ()
flags@NixStyleFlags{()
TestFlags
HaddockFlags
ConfigFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: ()
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
extraFlags :: forall a. NixStyleFlags a -> a
..} [String]
extraArgs GlobalFlags
globalFlags = do
  (ProjectBaseContext
baseCtx, ProjectConfig
projConfig) <- NixStyleFlags ()
-> [String]
-> GlobalFlags
-> IO (ProjectBaseContext, ProjectConfig)
configureAction' NixStyleFlags ()
flags [String]
extraArgs GlobalFlags
globalFlags

  if ProjectBaseContext -> Bool
shouldNotWriteFile ProjectBaseContext
baseCtx
    then Verbosity -> String -> IO ()
notice Verbosity
v String
"Config file not written due to flag(s)."
    else DistDirLayout -> ProjectConfig -> IO ()
writeProjectLocalExtraConfig (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx) ProjectConfig
projConfig
  where
    v :: Verbosity
v = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (CommonSetupFlags -> Flag Verbosity
setupVerbosity (CommonSetupFlags -> Flag Verbosity)
-> CommonSetupFlags -> Flag Verbosity
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags)

configureAction' :: NixStyleFlags () -> [String] -> GlobalFlags -> IO (ProjectBaseContext, ProjectConfig)
configureAction' :: NixStyleFlags ()
-> [String]
-> GlobalFlags
-> IO (ProjectBaseContext, ProjectConfig)
configureAction' flags :: NixStyleFlags ()
flags@NixStyleFlags{()
TestFlags
HaddockFlags
ConfigFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
extraFlags :: forall a. NixStyleFlags a -> a
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: ()
..} [String]
_extraArgs GlobalFlags
globalFlags = do
  -- TODO: deal with _extraArgs, since flags with wrong syntax end up there

  ProjectBaseContext
baseCtx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
v ProjectConfig
cliConfig CurrentCommand
OtherCommand

  let localFile :: String
localFile = DistDirLayout -> String -> String
distProjectFile (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx) String
"local"
  -- If cabal.project.local already exists, and the flags allow, back up to cabal.project.local~
  let backups :: Bool
backups = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
True (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigExFlags -> Flag Bool
configBackup ConfigExFlags
configExFlags
      appends :: Bool
appends = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigExFlags -> Flag Bool
configAppend ConfigExFlags
configExFlags
      backupFile :: String
backupFile = String
localFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"~"

  if ProjectBaseContext -> Bool
shouldNotWriteFile ProjectBaseContext
baseCtx
    then (ProjectBaseContext, ProjectConfig)
-> IO (ProjectBaseContext, ProjectConfig)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectConfig
cliConfig)
    else do
      Bool
exists <- String -> IO Bool
doesFileExist String
localFile
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exists Bool -> Bool -> Bool
&& Bool
backups) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Verbosity -> String -> IO ()
notice Verbosity
v (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> String
quote (String -> String
takeFileName String
localFile)
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" already exists, backing it up to "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
quote (String -> String
takeFileName String
backupFile)
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
        String -> String -> IO ()
copyFile String
localFile String
backupFile

      -- If the flag @configAppend@ is set to true, append and do not overwrite
      if Bool
exists Bool -> Bool -> Bool
&& Bool
appends
        then do
          HttpTransport
httpTransport <-
            Verbosity -> [String] -> Maybe String -> IO HttpTransport
configureTransport
              Verbosity
v
              (NubList String -> [String]
forall a. NubList a -> [a]
fromNubList (NubList String -> [String])
-> (ProjectConfigShared -> NubList String)
-> ProjectConfigShared
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigShared -> NubList String
projectConfigProgPathExtra (ProjectConfigShared -> [String])
-> ProjectConfigShared -> [String]
forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)
              (Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String)
-> (ProjectConfigBuildOnly -> Flag String)
-> ProjectConfigBuildOnly
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigBuildOnly -> Flag String
projectConfigHttpTransport (ProjectConfigBuildOnly -> Maybe String)
-> ProjectConfigBuildOnly -> Maybe String
forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
cliConfig)
          (CondNode ProjectConfig
conf [ProjectConfigPath]
imps [CondBranch ConfVar [ProjectConfigPath] ProjectConfig]
bs) <-
            String
-> Rebuild (CondTree ConfVar [ProjectConfigPath] ProjectConfig)
-> IO (CondTree ConfVar [ProjectConfigPath] ProjectConfig)
forall a. String -> Rebuild a -> IO a
runRebuild (DistDirLayout -> String
distProjectRootDirectory (DistDirLayout -> String)
-> (ProjectBaseContext -> DistDirLayout)
-> ProjectBaseContext
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBaseContext -> DistDirLayout
distDirLayout (ProjectBaseContext -> String) -> ProjectBaseContext -> String
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext
baseCtx) (Rebuild (CondTree ConfVar [ProjectConfigPath] ProjectConfig)
 -> IO (CondTree ConfVar [ProjectConfigPath] ProjectConfig))
-> Rebuild (CondTree ConfVar [ProjectConfigPath] ProjectConfig)
-> IO (CondTree ConfVar [ProjectConfigPath] ProjectConfig)
forall a b. (a -> b) -> a -> b
$
              Verbosity
-> HttpTransport
-> DistDirLayout
-> Rebuild (CondTree ConfVar [ProjectConfigPath] ProjectConfig)
readProjectLocalExtraConfig Verbosity
v HttpTransport
httpTransport (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([ProjectConfigPath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProjectConfigPath]
imps Bool -> Bool -> Bool
&& [CondBranch ConfVar [ProjectConfigPath] ProjectConfig] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CondBranch ConfVar [ProjectConfigPath] ProjectConfig]
bs)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
v CabalInstallException
UnableToPerformInplaceUpdate
          (ProjectBaseContext, ProjectConfig)
-> IO (ProjectBaseContext, ProjectConfig)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectConfig
conf ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig)
        else (ProjectBaseContext, ProjectConfig)
-> IO (ProjectBaseContext, ProjectConfig)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectBaseContext
baseCtx, ProjectConfig
cliConfig)
  where
    v :: Verbosity
v = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (CommonSetupFlags -> Flag Verbosity
setupVerbosity (CommonSetupFlags -> Flag Verbosity)
-> CommonSetupFlags -> Flag Verbosity
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags)
    cliConfig :: ProjectConfig
cliConfig =
      GlobalFlags
-> NixStyleFlags () -> ClientInstallFlags -> ProjectConfig
forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig
        GlobalFlags
globalFlags
        NixStyleFlags ()
flags
        ClientInstallFlags
forall a. Monoid a => a
mempty -- ClientInstallFlags, not needed here
    quote :: String -> String
quote String
s = String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"

-- Config file should not be written when certain flags are present
shouldNotWriteFile :: ProjectBaseContext -> Bool
shouldNotWriteFile :: ProjectBaseContext -> Bool
shouldNotWriteFile ProjectBaseContext
baseCtx =
  BuildTimeSettings -> Bool
buildSettingDryRun (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)
    Bool -> Bool -> Bool
|| BuildTimeSettings -> Bool
buildSettingOnlyDownload (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)