-----------------------------------------------------------------------------
-- |
-- Module : Main
-- Copyright : (c) David Himmelstrup 2005
-- License : BSD-like
--
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- Entry point to the default cabal-install front-end.
-----------------------------------------------------------------------------
module Main where
import Distribution.Client.Setup
( GlobalFlags(..), globalCommand, globalRepos
, ConfigFlags(..)
, ConfigExFlags(..), configureExCommand
, InstallFlags(..), defaultInstallFlags
, installCommand, upgradeCommand
, fetchCommand, checkCommand
, updateCommand
, ListFlags(..), listCommand
, InfoFlags(..), infoCommand
, UploadFlags(..), uploadCommand
, InitFlags, initCommand
, reportCommand
, unpackCommand, UnpackFlags(..)
, parsePackageArgs )
import Distribution.Simple.Setup
( BuildFlags(..), buildCommand
, HaddockFlags(..), haddockCommand
, HscolourFlags(..), hscolourCommand
, CopyFlags(..), copyCommand
, RegisterFlags(..), registerCommand
, CleanFlags(..), cleanCommand
, SDistFlags(..), sdistCommand
, TestFlags(..), testCommand
, Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.Client.Types
( UnresolvedDependency(UnresolvedDependency) )
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.Config
( SavedConfig(..), loadConfig, defaultConfigFile )
import Distribution.Client.List (list, info)
import Distribution.Client.Install (install, upgrade)
import Distribution.Client.Configure (configure)
import Distribution.Client.Update (update)
import Distribution.Client.Fetch (fetch)
import Distribution.Client.Check as Check (check)
--import Distribution.Client.Clean (clean)
import Distribution.Client.Upload as Upload (upload, check, report)
import Distribution.Client.SrcDist (sdist)
import Distribution.Client.Unpack (unpack)
import Distribution.Client.Init (initCabal)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Distribution.Simple.Compiler
( PackageDB(..), PackageDBStack )
import Distribution.Simple.Program (defaultProgramConfiguration)
import Distribution.Simple.Command
import Distribution.Simple.Configure (configCompilerAux)
import Distribution.Simple.Utils
( cabalVersion, die, topHandler, intercalate )
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
( Verbosity, normal, intToVerbosity )
import qualified Paths_cabal_install (version)
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.FilePath (splitExtension, takeExtension)
import System.Directory (doesFileExist)
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(..))
import Control.Monad (unless)
-- | Entry point
--
main :: IO ()
main = getArgs >>= mainWorker
mainWorker :: [String] -> IO ()
mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args
mainWorker args = topHandler $
case commandsRun globalCommand commands args of
CommandHelp help -> printGlobalHelp help
CommandList opts -> printOptionsList opts
CommandErrors errs -> printErrors errs
CommandReadyToGo (globalflags, commandParse) ->
case commandParse of
_ | fromFlag (globalVersion globalflags) -> printVersion
| fromFlag (globalNumericVersion globalflags) -> printNumericVersion
CommandHelp help -> printCommandHelp help
CommandList opts -> printOptionsList opts
CommandErrors errs -> printErrors errs
CommandReadyToGo action -> action globalflags
where
printCommandHelp help = do
pname <- getProgName
putStr (help pname)
printGlobalHelp help = do
pname <- getProgName
configFile <- defaultConfigFile
putStr (help pname)
putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"
++ " " ++ configFile ++ "\n"
printOptionsList = putStr . unlines
printErrors errs = do
putStr (concat (intersperse "\n" errs))
exitFailure
printNumericVersion = putStrLn $ display Paths_cabal_install.version
printVersion = putStrLn $ "cabal-install version "
++ display Paths_cabal_install.version
++ "\nusing version "
++ display cabalVersion
++ " of the Cabal library "
commands =
[configureExCommand `commandAddAction` configureAction
,installCommand `commandAddAction` installAction
,listCommand `commandAddAction` listAction
,infoCommand `commandAddAction` infoAction
,updateCommand `commandAddAction` updateAction
,upgradeCommand `commandAddAction` upgradeAction
,fetchCommand `commandAddAction` fetchAction
,uploadCommand `commandAddAction` uploadAction
,checkCommand `commandAddAction` checkAction
,sdistCommand `commandAddAction` sdistAction
,reportCommand `commandAddAction` reportAction
,unpackCommand `commandAddAction` unpackAction
,initCommand `commandAddAction` initAction
,wrapperAction (buildCommand defaultProgramConfiguration)
buildVerbosity buildDistPref
,wrapperAction copyCommand
copyVerbosity copyDistPref
,wrapperAction haddockCommand
haddockVerbosity haddockDistPref
,wrapperAction cleanCommand
cleanVerbosity cleanDistPref
,wrapperAction hscolourCommand
hscolourVerbosity hscolourDistPref
,wrapperAction registerCommand
regVerbosity regDistPref
,wrapperAction testCommand
testVerbosity testDistPref
]
wrapperAction :: Monoid flags
=> CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> Command (GlobalFlags -> IO ())
wrapperAction command verbosityFlag distPrefFlag =
commandAddAction command
{ commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do
let verbosity = fromFlagOrDefault normal (verbosityFlag flags)
setupScriptOptions = defaultSetupScriptOptions {
useDistPref = fromFlagOrDefault
(useDistPref defaultSetupScriptOptions)
(distPrefFlag flags)
}
setupWrapper verbosity setupScriptOptions Nothing
command (const flags) extraArgs
configureAction :: (ConfigFlags, ConfigExFlags)
-> [String] -> GlobalFlags -> IO ()
configureAction (configFlags, configExFlags) extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags)
(configUserInstall configFlags)
let configFlags' = savedConfigureFlags config `mappend` configFlags
configExFlags' = savedConfigureExFlags config `mappend` configExFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, conf) <- configCompilerAux configFlags'
configure verbosity
(configPackageDB' configFlags') (globalRepos globalFlags')
comp conf configFlags' configExFlags' extraArgs
installAction :: (ConfigFlags, ConfigExFlags, InstallFlags)
-> [String] -> GlobalFlags -> IO ()
installAction (configFlags, _, installFlags) _ _globalFlags
| fromFlagOrDefault False (installOnly installFlags)
= let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
in setupWrapper verbosity defaultSetupScriptOptions Nothing
installCommand (const mempty) []
installAction (configFlags, configExFlags, installFlags)
extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags)
(configUserInstall configFlags)
let configFlags' = savedConfigureFlags config `mappend` configFlags
configExFlags' = savedConfigureExFlags config `mappend` configExFlags
installFlags' = defaultInstallFlags `mappend`
savedInstallFlags config `mappend` installFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, conf) <- configCompilerAux configFlags'
install verbosity
(configPackageDB' configFlags') (globalRepos globalFlags')
comp conf configFlags' configExFlags' installFlags'
[ UnresolvedDependency pkg (configConfigurationsFlags configFlags')
| pkg <- pkgs ]
listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction listFlags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, conf) <- configCompilerAux configFlags
list verbosity
(configPackageDB' configFlags)
(globalRepos globalFlags')
comp
conf
listFlags
extraArgs
infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()
infoAction infoFlags extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlag (infoVerbosity infoFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, conf) <- configCompilerAux configFlags
info verbosity
(configPackageDB' configFlags)
(globalRepos globalFlags')
comp
conf
infoFlags
[ UnresolvedDependency pkg [] | pkg <- pkgs ]
updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
updateAction verbosityFlag extraArgs globalFlags = do
unless (null extraArgs) $ do
die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs
let verbosity = fromFlag verbosityFlag
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
update verbosity (globalRepos globalFlags')
upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags)
-> [String] -> GlobalFlags -> IO ()
upgradeAction (configFlags, configExFlags, installFlags)
extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags)
(configUserInstall configFlags)
let configFlags' = savedConfigureFlags config `mappend` configFlags
configExFlags' = savedConfigureExFlags config `mappend` configExFlags
installFlags' = savedInstallFlags config `mappend` installFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, conf) <- configCompilerAux configFlags'
upgrade verbosity
(configPackageDB' configFlags') (globalRepos globalFlags')
comp conf configFlags' configExFlags' installFlags'
[ UnresolvedDependency pkg (configConfigurationsFlags configFlags')
| pkg <- pkgs ]
fetchAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
fetchAction verbosityFlag extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlag verbosityFlag
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, conf) <- configCompilerAux configFlags
fetch verbosity
(configPackageDB' configFlags) (globalRepos globalFlags')
comp conf
[ UnresolvedDependency pkg [] --TODO: flags?
| pkg <- pkgs ]
uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()
uploadAction uploadFlags extraArgs globalFlags = do
let verbosity = fromFlag (uploadVerbosity uploadFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let uploadFlags' = savedUploadFlags config `mappend` uploadFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
tarfiles = extraArgs
checkTarFiles extraArgs
if fromFlag (uploadCheck uploadFlags')
then Upload.check verbosity tarfiles
else upload verbosity
(globalRepos globalFlags')
(flagToMaybe $ uploadUsername uploadFlags')
(flagToMaybe $ uploadPassword uploadFlags')
tarfiles
where
checkTarFiles tarfiles
| null tarfiles
= die "the 'upload' command expects one or more .tar.gz packages."
| not (null otherFiles)
= die $ "the 'upload' command expects only .tar.gz packages: "
++ intercalate ", " otherFiles
| otherwise = sequence_
[ do exists <- doesFileExist tarfile
unless exists $ die $ "file not found: " ++ tarfile
| tarfile <- tarfiles ]
where otherFiles = filter (not . isTarGzFile) tarfiles
isTarGzFile file = case splitExtension file of
(file', ".gz") -> takeExtension file' == ".tar"
_ -> False
checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
checkAction verbosityFlag extraArgs _globalFlags = do
unless (null extraArgs) $ do
die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs
allOk <- Check.check (fromFlag verbosityFlag)
unless allOk exitFailure
sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO ()
sdistAction sflags extraArgs _globalFlags = do
unless (null extraArgs) $ do
die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs
sdist sflags
reportAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
reportAction verbosityFlag extraArgs globalFlags = do
unless (null extraArgs) $ do
die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs
let verbosity = fromFlag verbosityFlag
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
Upload.report verbosity (globalRepos globalFlags')
unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()
unpackAction flags extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlag (unpackVerbosity flags)
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
unpack flags (globalRepos (savedGlobalFlags config)) pkgs
initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()
initAction flags _extraArgs _globalFlags = do
initCabal flags
win32SelfUpgradeAction :: [String] -> IO ()
win32SelfUpgradeAction (pid:path:rest) =
Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path
where
verbosity = case rest of
(['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9']
-> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n]))
_ -> Verbosity.normal
win32SelfUpgradeAction _ = return ()
--
-- Utils (transitionary)
--
-- | Currently the user interface specifies the package dbs to use with just a
-- single valued option, a 'PackageDB'. However internally we represent the
-- stack of 'PackageDB's explictly as a list. This function converts encodes
-- the package db stack implicit in a single packagedb.
--
-- TODO: sort this out, make it consistent with the command line UI
implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack
implicitPackageDbStack userInstall packageDbFlag
| userInstall = GlobalPackageDB : UserPackageDB : extra
| otherwise = GlobalPackageDB : extra
where
extra = case packageDbFlag of
Just (SpecificPackageDB db) -> [SpecificPackageDB db]
_ -> []
configPackageDB' :: ConfigFlags -> PackageDBStack
configPackageDB' cfg =
implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg))
where
userInstall = fromFlagOrDefault True (configUserInstall cfg)