-----------------------------------------------------------------------------
-- |
-- 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(..), configureCommand
, InstallFlags(..), installCommand, upgradeCommand
, fetchCommand, checkCommand
, updateCommand
, ListFlags(..), listCommand
, UploadFlags(..), uploadCommand
, reportCommand
, parsePackageArgs, configPackageDB' )
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 )
import Distribution.Client.List (list)
import Distribution.Client.Install (install, upgrade)
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 qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Distribution.Simple.Program (defaultProgramConfiguration)
import Distribution.Simple.Command
import Distribution.Simple.Configure (configCompilerAux)
import Distribution.Simple.Utils (cabalVersion, die, 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 =
case commandsRun globalCommand commands args of
CommandHelp help -> printHelp 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 -> printHelp help
CommandList opts -> printOptionsList opts
CommandErrors errs -> printErrors errs
CommandReadyToGo action -> action globalflags
where
printHelp help = getProgName >>= putStr . help
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 =
[configureCommand `commandAddAction` configureAction
,installCommand `commandAddAction` installAction
,listCommand `commandAddAction` listAction
,updateCommand `commandAddAction` updateAction
,upgradeCommand `commandAddAction` upgradeAction
,fetchCommand `commandAddAction` fetchAction
,uploadCommand `commandAddAction` uploadAction
,checkCommand `commandAddAction` checkAction
,sdistCommand `commandAddAction` sdistAction
,reportCommand `commandAddAction` reportAction
,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 -> [String] -> GlobalFlags -> IO ()
configureAction flags extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (configVerbosity flags)
config <- loadConfig verbosity (globalConfigFile globalFlags)
(configUserInstall flags)
let flags' = savedConfigureFlags config `mappend` flags
(comp, conf) <- configCompilerAux flags'
let setupScriptOptions = defaultSetupScriptOptions {
useCompiler = Just comp,
useProgramConfig = conf,
useDistPref = fromFlagOrDefault
(useDistPref defaultSetupScriptOptions)
(configDistPref flags)
}
setupWrapper verbosity setupScriptOptions Nothing
configureCommand (const flags') extraArgs
installAction :: (ConfigFlags, InstallFlags) -> [String] -> GlobalFlags -> IO ()
installAction (cflags,iflags) _ _globalFlags
| fromFlagOrDefault False (installOnly iflags)
= let verbosity = fromFlagOrDefault normal (configVerbosity cflags)
in setupWrapper verbosity defaultSetupScriptOptions Nothing
installCommand mempty []
installAction (cflags,iflags) extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlagOrDefault normal (configVerbosity cflags)
config <- loadConfig verbosity (globalConfigFile globalFlags)
(configUserInstall cflags)
let cflags' = savedConfigureFlags config `mappend` cflags
iflags' = savedInstallFlags config `mappend` iflags
(comp, conf) <- configCompilerAux cflags'
install verbosity
(configPackageDB' cflags') (globalRepos (savedGlobalFlags config))
comp conf cflags' iflags'
[ UnresolvedDependency pkg (configConfigurationsFlags cflags')
| pkg <- pkgs ]
listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction listFlags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let flags = savedConfigureFlags config
(comp, conf) <- configCompilerAux flags
list verbosity
(configPackageDB' flags)
(globalRepos (savedGlobalFlags config))
comp
conf
listFlags
extraArgs
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
update verbosity (globalRepos (savedGlobalFlags config))
upgradeAction :: (ConfigFlags, InstallFlags) -> [String] -> GlobalFlags -> IO ()
upgradeAction (cflags,iflags) extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlagOrDefault normal (configVerbosity cflags)
config <- loadConfig verbosity (globalConfigFile globalFlags)
(configUserInstall cflags)
let cflags' = savedConfigureFlags config `mappend` cflags
iflags' = savedInstallFlags config `mappend` iflags
(comp, conf) <- configCompilerAux cflags'
upgrade verbosity
(configPackageDB' cflags') (globalRepos (savedGlobalFlags config))
comp conf cflags' iflags'
[ UnresolvedDependency pkg (configConfigurationsFlags cflags')
| 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 flags = savedConfigureFlags config
(comp, conf) <- configCompilerAux flags
fetch verbosity
(configPackageDB' flags) (globalRepos (savedGlobalFlags config))
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
-- FIXME: check that the .tar.gz files exist and report friendly error message if not
let tarfiles = extraArgs
checkTarFiles tarfiles
if fromFlag (uploadCheck uploadFlags')
then Upload.check verbosity tarfiles
else upload verbosity
(globalRepos (savedGlobalFlags config))
(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
Upload.report verbosity (globalRepos (savedGlobalFlags config))
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 ()