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

Author: phadej

cabal-install/Distribution/Client/CmdInstall.hs

@@ -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,

cabal-install/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs

@@ -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

cabal-install/Distribution/Client/CmdRepl.hs

@@ -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
 

cabal-install/Distribution/Client/CmdRun.hs

@@ -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