Commit f4ecbf19 authored by Oleg Grenrus's avatar Oleg Grenrus

Resolve #6393. Allow cabal v2-install http://....

parent ff9d62dc
......@@ -15,6 +15,8 @@ module Distribution.Client.CmdInstall (
TargetProblem(..),
selectPackageTargets,
selectComponentTarget,
-- * Internals exposed for CmdRepl + CmdRun
establishDummyDistDirLayout,
establishDummyProjectBaseContext
) where
......@@ -44,6 +46,10 @@ import Distribution.Package
( Package(..), PackageName, mkPackageName, unPackageName )
import Distribution.Types.PackageId
( PackageIdentifier(..) )
import Distribution.Client.ProjectConfig
( ProjectPackageLocation(..)
, fetchAndReadSourcePackages
)
import Distribution.Client.ProjectConfig.Types
( ProjectConfig(..), ProjectConfigShared(..)
, ProjectConfigBuildOnly(..), PackageConfig(..)
......@@ -136,6 +142,7 @@ import Data.Ord
import qualified Data.Map as Map
import Distribution.Utils.NubList
( fromNubList )
import Network.URI (URI)
import System.Directory
( getHomeDirectory, doesFileExist, createDirectoryIfMissing
, getTemporaryDirectory, makeAbsolute, doesDirectoryExist
......@@ -262,7 +269,7 @@ installAction ( configFlags, configExFlags, installFlags
targetFilter = if installLibs then Just LibKind else Just ExeKind
targetStrings' = if null targetStrings then ["."] else targetStrings
withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector], ProjectConfig)
withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
withProject = do
let verbosity' = lessVerbose verbosity
......@@ -292,7 +299,7 @@ installAction ( configFlags, configExFlags, installFlags
flip TargetPackageNamed targetFilter . pkgName <$> packageIds
if null targetStrings'
then return (packageSpecifiers, packageTargets, projectConfig localBaseCtx)
then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx)
else do
targetSelectors <-
either (reportTargetSelectorProblems verbosity) return
......@@ -397,10 +404,11 @@ installAction ( configFlags, configExFlags, installFlags
else return (local ++ hackagePkgs, targets' ++ hackageTargets)
return ( specs ++ packageSpecifiers
, []
, selectors ++ packageTargets
, projectConfig localBaseCtx )
withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [TargetSelector], ProjectConfig)
withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig)
withoutProject globalConfig = do
tss <- mapM (parseWithoutProjectTargetSelector verbosity) targetStrings'
......@@ -441,14 +449,15 @@ installAction ( configFlags, configExFlags, installFlags
]
let
packageSpecifiers = woPackageSpecifiers <$> tss
packageTargets = woPackageTargets <$> tss
return (packageSpecifiers, packageTargets, projectConfig)
(uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss
packageTargets = map woPackageTargets tss
return (packageSpecifiers, uris, packageTargets, projectConfig)
let
ignoreProject = fromFlagOrDefault False (cinstIgnoreProject clientInstallFlags)
(specs, selectors, config) <-
(specs, uris, selectors, config) <-
withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag withProject withoutProject
home <- getHomeDirectory
......@@ -551,16 +560,21 @@ installAction ( configFlags, configExFlags, installFlags
envSpecs' | installLibs = envSpecs
| otherwise = []
withTempDirectory
verbosity
globalTmp
"cabal-install."
$ \tmpDir -> do
withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do
distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir
uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages
verbosity
distDirLayout
(projectConfigShared config)
(projectConfigBuildOnly config)
[ ProjectPackageRemoteTarball uri | uri <- uris ]
baseCtx <- establishDummyProjectBaseContext
verbosity
config
tmpDir
(envSpecs' ++ specs)
distDirLayout
(envSpecs' ++ specs ++ uriSpecs)
InstallCommand
buildCtx <-
......@@ -867,21 +881,15 @@ entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) []
establishDummyProjectBaseContext
:: Verbosity
-> ProjectConfig
-> FilePath
-> DistDirLayout
-- ^ Where to put the dist directory
-> [PackageSpecifier UnresolvedSourcePackage]
-- ^ The packages to be included in the project
-> CurrentCommand
-> IO ProjectBaseContext
establishDummyProjectBaseContext verbosity cliConfig tmpDir
localPackages currentCommand = do
establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do
cabalDir <- getCabalDir
-- Create the dist directories
createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout
createDirectoryIfMissingVerbose verbosity True $
distProjectCacheDirectory distDirLayout
globalConfig <- runRebuild ""
$ readGlobalConfig verbosity
$ projectConfigConfigFile
......@@ -912,13 +920,21 @@ establishDummyProjectBaseContext verbosity cliConfig tmpDir
buildSettings,
currentCommand
}
establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout
establishDummyDistDirLayout verbosity cliConfig tmpDir = do
let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory
-- Create the dist directories
createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout
createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout
return distDirLayout
where
mdistDirectory = flagToMaybe
$ projectConfigDistDir
$ projectConfigShared cliConfig
projectRoot = ProjectRootImplicit tmpDir
distDirLayout = defaultDistDirLayout projectRoot
mdistDirectory
-- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
......
......@@ -9,6 +9,8 @@ module Distribution.Client.CmdInstall.ClientInstallTargetSelector (
import Distribution.Client.Compat.Prelude
import Prelude ()
import Network.URI (URI, parseURI)
import Distribution.Client.TargetSelector
import Distribution.Client.Types
import Distribution.Compat.CharParsing (char, optional)
......@@ -23,14 +25,16 @@ import Distribution.Version
data WithoutProjectTargetSelector
= WoPackageId PackageId
| WoPackageComponent PackageId ComponentName
-- | WoURI URI
| WoURI URI
deriving (Show)
parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector
parseWithoutProjectTargetSelector verbosity input =
case explicitEitherParsec parser input of
Right ts -> return ts
Left err -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err
Left err -> case parseURI input of
Just uri -> return (WoURI uri)
Nothing -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err
where
parser :: ParsecParser WithoutProjectTargetSelector
parser = do
......@@ -43,16 +47,20 @@ parseWithoutProjectTargetSelector verbosity input =
woPackageNames :: WithoutProjectTargetSelector -> [PackageName]
woPackageNames (WoPackageId pid) = [pkgName pid]
woPackageNames (WoPackageComponent pid _) = [pkgName pid]
woPackageNames (WoURI _) = []
woPackageTargets :: WithoutProjectTargetSelector -> TargetSelector
woPackageTargets (WoPackageId pid) =
TargetPackageNamed (pkgName pid) Nothing
woPackageTargets (WoPackageComponent pid cn) =
TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent
woPackageTargets (WoURI _) =
TargetAllPackages (Just ExeKind)
woPackageSpecifiers :: WithoutProjectTargetSelector -> PackageSpecifier pkg
woPackageSpecifiers (WoPackageId pid) = pidPackageSpecifiers pid
woPackageSpecifiers (WoPackageComponent pid _) = pidPackageSpecifiers pid
woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg)
woPackageSpecifiers (WoPackageId pid) = Right (pidPackageSpecifiers pid)
woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid)
woPackageSpecifiers (WoURI uri) = Left uri
pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg
pidPackageSpecifiers pid
......
......@@ -25,7 +25,9 @@ import qualified Distribution.Types.Lens as L
import Distribution.Client.CmdErrorMessages
import Distribution.Client.CmdInstall
( establishDummyProjectBaseContext )
( establishDummyDistDirLayout
, establishDummyProjectBaseContext
)
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.ProjectBuilding
( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages )
......@@ -419,11 +421,12 @@ withoutProject config verbosity extraArgs = do
cwd <- getCurrentDirectory
writeFile ghciScriptPath (":cd " ++ cwd)
distDirLayout <- establishDummyDistDirLayout verbosity config tempDir
baseCtx <-
establishDummyProjectBaseContext
verbosity
config
tempDir
distDirLayout
[SpecificSourcePackage sourcePackage]
OtherCommand
......
......@@ -47,7 +47,8 @@ import Distribution.Simple.Utils
( wrapText, warn, die', ordNub, info
, createTempDirectory, handleDoesNotExist )
import Distribution.Client.CmdInstall
( establishDummyProjectBaseContext )
( establishDummyDistDirLayout
, establishDummyProjectBaseContext )
import Distribution.Client.ProjectConfig
( ProjectConfig(..), ProjectConfigShared(..)
, withProjectOrGlobalConfigIgn )
......@@ -200,13 +201,14 @@ runAction ( configFlags, configExFlags, installFlags
, clientRunFlags )
targetStrings globalFlags = do
globalTmp <- getTemporaryDirectory
tempDir <- createTempDirectory globalTmp "cabal-repl."
tmpDir <- createTempDirectory globalTmp "cabal-repl."
let
with =
establishProjectBaseContext verbosity cliConfig OtherCommand
without config =
establishDummyProjectBaseContext verbosity (config <> cliConfig) tempDir [] OtherCommand
without config = do
distDirLayout <- establishDummyDistDirLayout verbosity (config <> cliConfig) tmpDir
establishDummyProjectBaseContext verbosity (config <> cliConfig) distDirLayout [] OtherCommand
let
ignoreProject = fromFlagOrDefault False (crunIgnoreProject clientRunFlags)
......@@ -219,7 +221,7 @@ runAction ( configFlags, configExFlags, installFlags
let pol | takeExtension script == ".lhs" = LiterateHaskell
| otherwise = PlainHaskell
if exists
then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tempDir
then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tmpDir
else reportTargetSelectorProblems verbosity err
(baseCtx', targetSelectors) <-
......@@ -337,7 +339,7 @@ runAction ( configFlags, configExFlags, installFlags
elaboratedPlan
}
handleDoesNotExist () (removeDirectoryRecursive tempDir)
handleDoesNotExist () (removeDirectoryRecursive tmpDir)
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig
......@@ -441,7 +443,7 @@ handleScriptCase
-> FilePath
-> BS.ByteString
-> IO (ProjectBaseContext, [TargetSelector])
handleScriptCase verbosity pol baseCtx tempDir scriptContents = do
handleScriptCase verbosity pol baseCtx tmpDir scriptContents = do
(executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents
-- We need to create a dummy package that lives in our dummy project.
......@@ -453,7 +455,7 @@ handleScriptCase verbosity pol baseCtx tempDir scriptContents = do
sourcePackage = SourcePackage
{ packageInfoId = pkgId
, SP.packageDescription = genericPackageDescription
, packageSource = LocalUnpackedPackage tempDir
, packageSource = LocalUnpackedPackage tmpDir
, packageDescrOverride = Nothing
}
genericPackageDescription = emptyGenericPackageDescription
......@@ -477,8 +479,8 @@ handleScriptCase verbosity pol baseCtx tempDir scriptContents = do
}
pkgId = fakePackageId
writeGenericPackageDescription (tempDir </> "fake-package.cabal") genericPackageDescription
BS.writeFile (tempDir </> mainName) contents'
writeGenericPackageDescription (tmpDir </> "fake-package.cabal") genericPackageDescription
BS.writeFile (tmpDir </> mainName) contents'
let
baseCtx' = baseCtx
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment