{-# 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.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{()
HaddockFlags
BenchmarkFlags
ConfigFlags
TestFlags
ProjectFlags
InstallFlags
ConfigExFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: ()
extraFlags :: forall a. NixStyleFlags a -> a
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
..} [String]
extraArgs GlobalFlags
globalFlags = do
  (baseCtx, projConfig) <- NixStyleFlags ()
-> [String]
-> GlobalFlags
-> IO (ProjectBaseContext, ProjectConfig)
configureAction' NixStyleFlags ()
flags [String]
extraArgs GlobalFlags
globalFlags

  if shouldNotWriteFile baseCtx
    then notice v "Config file not written due to flag(s)."
    else writeProjectLocalExtraConfig (distDirLayout baseCtx) projConfig
  where
    v :: Verbosity
v = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)

configureAction' :: NixStyleFlags () -> [String] -> GlobalFlags -> IO (ProjectBaseContext, ProjectConfig)
configureAction' :: NixStyleFlags ()
-> [String]
-> GlobalFlags
-> IO (ProjectBaseContext, ProjectConfig)
configureAction' flags :: NixStyleFlags ()
flags@NixStyleFlags{()
HaddockFlags
BenchmarkFlags
ConfigFlags
TestFlags
ProjectFlags
InstallFlags
ConfigExFlags
extraFlags :: forall a. NixStyleFlags a -> a
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
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

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

  let 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 -> 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 -> 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
localFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"~"

  if shouldNotWriteFile baseCtx
    then return (baseCtx, cliConfig)
    else do
      exists <- doesFileExist localFile
      when (exists && backups) $ do
        notice v $
          quote (takeFileName localFile)
            <> " already exists, backing it up to "
            <> quote (takeFileName backupFile)
            <> "."
        copyFile localFile backupFile

      -- If the flag @configAppend@ is set to true, append and do not overwrite
      if exists && appends
        then do
          httpTransport <-
            configureTransport
              v
              (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
              (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
          (CondNode conf imps bs) <-
            runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $
              readProjectLocalExtraConfig v httpTransport (distDirLayout baseCtx)
          when (not (null imps && null bs)) $ dieWithException v UnableToPerformInplaceUpdate
          return (baseCtx, conf <> cliConfig)
        else return (baseCtx, cliConfig)
  where
    v :: Verbosity
v = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity 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)