Merge pull request #6576 from phadej/issue-6369-install-pkgname-exename

Resolve #6369 and #6393: Allow cabal v2-install pkgname:exename or http://example.com/package.tar.gz(#sha256=abcde...)

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
 
@@ -28,6 +30,7 @@ import Distribution.Client.CmdErrorMessages
 import Distribution.Client.CmdSdist
 
 import Distribution.Client.CmdInstall.ClientInstallFlags
+import Distribution.Client.CmdInstall.ClientInstallTargetSelector
 
 import Distribution.Client.Setup
          ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..)
@@ -43,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(..)
@@ -135,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
@@ -261,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
 
@@ -291,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
@@ -396,16 +404,13 @@ 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
-      let
-        parsePkg pkgName
-          | Just (pkg :: PackageId) <- simpleParse pkgName = return pkg
-          | otherwise = die' verbosity ("Invalid package ID: " ++ pkgName)
-      packageIds <- mapM parsePkg targetStrings'
+      tss <- mapM (parseWithoutProjectTargetSelector verbosity) targetStrings'
 
       cabalDir <- getCabalDir
       let
@@ -431,31 +436,28 @@ installAction ( configFlags, configExFlags, installFlags
                                             verbosity buildSettings
                                             (getSourcePackages verbosity)
 
-      for_ targetStrings' $ \case
-            name
-              | null (lookupPackageName packageIndex (mkPackageName name))
-              , xs@(_:_) <- searchByName packageIndex name ->
-                die' verbosity . concat $
-                            [ "Unknown package \"", name, "\". "
-                            , "Did you mean any of the following?\n"
-                            , unlines (("- " ++) . unPackageName . fst <$> xs)
-                            ]
-            _ -> return ()
+      for_ (concatMap woPackageNames tss) $ \name -> do
+        when (null (lookupPackageName packageIndex name)) $ do
+          let xs = searchByName packageIndex (unPackageName name)
+          let emptyIf True  _  = []
+              emptyIf False zs = zs
+          die' verbosity $ concat $
+            [ "Unknown package \"", unPackageName name, "\". "
+            ] ++ emptyIf (null xs)
+            [ "Did you mean any of the following?\n"
+            , unlines (("- " ++) . unPackageName . fst <$> xs)
+            ]
 
       let
-        packageSpecifiers = flip fmap packageIds $ \case
-          PackageIdentifier{..}
-            | pkgVersion == nullVersion -> NamedPackage pkgName []
-            | otherwise                 -> NamedPackage pkgName
-                                           [PackagePropertyVersion
-                                            (thisVersion pkgVersion)]
-        packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds
-      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
@@ -558,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 <-
@@ -874,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
@@ -919,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

@@ -0,0 +1,70 @@
+module Distribution.Client.CmdInstall.ClientInstallTargetSelector (
+    WithoutProjectTargetSelector (..),
+    parseWithoutProjectTargetSelector,
+    woPackageNames,
+    woPackageTargets,
+    woPackageSpecifiers,
+    ) where
+
+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)
+import Distribution.Package
+import Distribution.Parsec
+import Distribution.Simple.LocalBuildInfo          (ComponentName (CExeName))
+import Distribution.Simple.Utils                   (die')
+import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
+import Distribution.Verbosity                      (Verbosity)
+import Distribution.Version
+
+data WithoutProjectTargetSelector
+    = WoPackageId PackageId
+    | WoPackageComponent PackageId ComponentName
+    | WoURI URI
+  deriving (Show)
+
+parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector
+parseWithoutProjectTargetSelector verbosity input =
+    case explicitEitherParsec parser input of
+        Right ts -> return ts
+        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
+        pid <- parsec
+        cn  <- optional (char ':' *> parsec)
+        return $ case cn of
+            Nothing -> WoPackageId pid
+            Just cn' -> WoPackageComponent pid (CExeName cn')
+
+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 -> 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
+    | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) []
+    | otherwise                     = NamedPackage (pkgName pid)
+        [ PackagePropertyVersion (thisVersion (pkgVersion 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