Merge branch 'master' into changelog-d/1.0.1

Cabal/src/Distribution/PackageDescription/Check.hs

@@ -684,6 +684,7 @@ checkSourceRepos rs = do
         checkP
           (isNothing repoLocation_)
           (PackageDistInexcusable MissingLocation)
+        checkGitProtocol repoLocation_
         checkP
           ( repoType_ == Just (KnownRepoType CVS)
               && isNothing repoModule_
@@ -722,6 +723,17 @@ checkMissingVcsInfo rs =
     repoTypeDirname Monotone = ["_MTN"]
     repoTypeDirname Pijul = [".pijul"]
 
+-- git:// lacks TLS or other encryption, see
+-- https://git-scm.com/book/en/v2/Git-on-the-Server-The-Protocols#_the_cons_4
+checkGitProtocol
+  :: Monad m
+  => Maybe String -- Repository location
+  -> CheckM m ()
+checkGitProtocol mloc =
+  checkP
+    (fmap (isPrefixOf "git://") mloc == Just True)
+    (PackageBuildWarning GitProtocol)
+
 -- ------------------------------------------------------------
 -- Package and distribution checks
 -- ------------------------------------------------------------

Cabal/src/Distribution/PackageDescription/Check/Warning.hs

@@ -193,6 +193,7 @@ data CheckExplanation
   | UnrecognisedSourceRepo String
   | MissingType
   | MissingLocation
+  | GitProtocol
   | MissingModule
   | MissingTag
   | SubdirRelPath
@@ -355,6 +356,7 @@ data CheckExplanationID
   | CIUnrecognisedSourceRepo
   | CIMissingType
   | CIMissingLocation
+  | CIGitProtocol
   | CIMissingModule
   | CIMissingTag
   | CISubdirRelPath
@@ -496,6 +498,7 @@ checkExplanationId (NoLicenseFile{}) = CINoLicenseFile
 checkExplanationId (UnrecognisedSourceRepo{}) = CIUnrecognisedSourceRepo
 checkExplanationId (MissingType{}) = CIMissingType
 checkExplanationId (MissingLocation{}) = CIMissingLocation
+checkExplanationId (GitProtocol{}) = CIGitProtocol
 checkExplanationId (MissingModule{}) = CIMissingModule
 checkExplanationId (MissingTag{}) = CIMissingTag
 checkExplanationId (SubdirRelPath{}) = CISubdirRelPath
@@ -642,6 +645,7 @@ ppCheckExplanationId CINoLicenseFile = "no-license-file"
 ppCheckExplanationId CIUnrecognisedSourceRepo = "unrecognised-repo-type"
 ppCheckExplanationId CIMissingType = "repo-no-type"
 ppCheckExplanationId CIMissingLocation = "repo-no-location"
+ppCheckExplanationId CIGitProtocol = "git-protocol"
 ppCheckExplanationId CIMissingModule = "repo-no-module"
 ppCheckExplanationId CIMissingTag = "repo-no-tag"
 ppCheckExplanationId CISubdirRelPath = "repo-relative-dir"
@@ -964,6 +968,10 @@ ppExplanation MissingType =
   "The source-repository 'type' is a required field."
 ppExplanation MissingLocation =
   "The source-repository 'location' is a required field."
+ppExplanation GitProtocol =
+  "Cloning over git:// might lead to an arbitrary code execution "
+    ++ "vulnerability. Furthermore, popular forges like GitHub do "
+    ++ "not support it. Use https:// or ssh:// instead."
 ppExplanation MissingModule =
   "For a CVS source-repository, the 'module' is a required field."
 ppExplanation MissingTag =

cabal-install/src/Distribution/Client/HttpUtils.hs

@@ -192,7 +192,7 @@ downloadURI transport verbosity uri path = do
   -- Only use the external http transports if we actually have to
   -- (or have been told to do so)
   let transport'
-        | uriScheme uri == "http:"
+        | isHttpURI uri
         , not (transportManuallySelected transport) =
             plainHttpTransport
         | otherwise =
@@ -251,20 +251,35 @@ downloadURI transport verbosity uri path = do
 -- Utilities for repo url management
 --
 
+-- | If the remote repo is accessed over HTTPS, ensure that the transport
+-- supports HTTPS.
 remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
-remoteRepoCheckHttps verbosity transport repo
-  | uriScheme (remoteRepoURI repo) == "https:"
-  , not (transportSupportsHttps transport) =
-      dieWithException verbosity $ RemoteRepoCheckHttps (unRepoName (remoteRepoName repo)) requiresHttpsErrorMessage
-  | otherwise = return ()
+remoteRepoCheckHttps verbosity transport repo =
+  transportCheckHttpsWithError verbosity transport (remoteRepoURI repo) $
+    RemoteRepoCheckHttps (unRepoName (remoteRepoName repo)) requiresHttpsErrorMessage
 
+-- | If the URI scheme is HTTPS, ensure the transport supports HTTPS.
 transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
-transportCheckHttps verbosity transport uri
-  | uriScheme uri == "https:"
+transportCheckHttps verbosity transport uri =
+  transportCheckHttpsWithError verbosity transport uri $
+    TransportCheckHttps uri requiresHttpsErrorMessage
+
+-- | If the URI scheme is HTTPS, ensure the transport supports HTTPS.
+-- If not, fail with the given error.
+transportCheckHttpsWithError
+  :: Verbosity -> HttpTransport -> URI -> CabalInstallException -> IO ()
+transportCheckHttpsWithError verbosity transport uri err
+  | isHttpsURI uri
   , not (transportSupportsHttps transport) =
-      dieWithException verbosity $ TransportCheckHttps uri requiresHttpsErrorMessage
+      dieWithException verbosity err
   | otherwise = return ()
 
+isHttpsURI :: URI -> Bool
+isHttpsURI uri = uriScheme uri == "https:"
+
+isHttpURI :: URI -> Bool
+isHttpURI uri = uriScheme uri == "http:"
+
 requiresHttpsErrorMessage :: String
 requiresHttpsErrorMessage =
   "requires HTTPS however the built-in HTTP implementation "
@@ -280,12 +295,12 @@ requiresHttpsErrorMessage =
 remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
 remoteRepoTryUpgradeToHttps verbosity transport repo
   | remoteRepoShouldTryHttps repo
-  , uriScheme (remoteRepoURI repo) == "http:"
+  , isHttpURI (remoteRepoURI repo)
   , not (transportSupportsHttps transport)
   , not (transportManuallySelected transport) =
       dieWithException verbosity $ TryUpgradeToHttps [name | (name, _, True, _) <- supportedTransports]
   | remoteRepoShouldTryHttps repo
-  , uriScheme (remoteRepoURI repo) == "http:"
+  , isHttpURI (remoteRepoURI repo)
   , transportSupportsHttps transport =
       return
         repo
@@ -505,12 +520,18 @@ curlTransport prog =
             (Just (Left (uname, passwd)), _) -> Just $ Left (uname ++ ":" ++ passwd)
             (Nothing, Just a) -> Just $ Left a
             (Nothing, Nothing) -> Nothing
+      let authnSchemeArg
+            -- When using TLS, we can accept Basic authentication.  Let curl
+            -- decide based on the scheme(s) offered by the server.
+            | isHttpsURI uri = "--anyauth"
+            -- When not using TLS, force Digest scheme
+            | otherwise = "--digest"
       case mbAuthStringToken of
         Just (Left up) ->
           progInvocation
             { progInvokeInput =
                 Just . IODataText . unlines $
-                  [ "--digest"
+                  [ authnSchemeArg
                   , "--user " ++ up
                   ]
             , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation

cabal-install/src/Distribution/Client/Init.hs

@@ -41,8 +41,7 @@ initCmd v packageDBs repoCtxt comp progdb initFlags = do
   installedPkgIndex <- getInstalledPackages v comp packageDBs progdb
   sourcePkgDb <- getSourcePackages v repoCtxt
   hSetBuffering stdout NoBuffering
-  settings <- createProject v installedPkgIndex sourcePkgDb initFlags
-  writeProject settings
+  runPromptIO (writeProject =<< createProject v installedPkgIndex sourcePkgDb initFlags)
   where
     -- When no flag is set, default to interactive.
     --

cabal-install/src/Distribution/Client/Init/Interactive/Command.hs

@@ -460,14 +460,18 @@ languagePrompt flags pkgType = getLanguage flags $ do
       ghc2021 = "GHC2021 (requires at least GHC 9.2)"
       ghc2024 = "GHC2024 (requires at least GHC 9.10)"
 
+  lastChosenLanguage <- getLastChosenLanguage
+
   l <-
     promptList
       ("Choose a language for your " ++ pkgType)
       [h2010, h98, ghc2021, ghc2024]
-      (DefaultPrompt h2010)
+      (DefaultPrompt (maybe h2010 id lastChosenLanguage))
       Nothing
       True
 
+  setLastChosenLanguage (Just l)
+
   if
       | l == h2010 -> return Haskell2010
       | l == h98 -> return Haskell98

cabal-install/src/Distribution/Client/Init/Types.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 
 -- |
@@ -39,7 +40,11 @@ module Distribution.Client.Init.Types
     -- * Typeclasses
   , Interactive (..)
   , BreakException (..)
-  , PurePrompt (..)
+  , PromptIO
+  , runPromptIO
+  , Inputs
+  , PurePrompt
+  , runPrompt
   , evalPrompt
   , Severity (..)
 
@@ -63,9 +68,12 @@ import qualified Distribution.Client.Compat.Prelude as P
 import Prelude (read)
 
 import Control.Monad.Catch
+import Control.Monad.IO.Class
+import Control.Monad.Reader
 
 import Data.List.NonEmpty (fromList)
 
+import qualified Data.IORef
 import Distribution.CabalSpecVersion
 import Distribution.Client.Utils as P
 import Distribution.Fields.Pretty
@@ -282,15 +290,33 @@ mkLiterate _ hs = hs
 -- -------------------------------------------------------------------- --
 -- Interactive prompt monad
 
+newtype PromptIO a = PromptIO (ReaderT (Data.IORef.IORef SessionState) IO a)
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+sessionState :: PromptIO (Data.IORef.IORef SessionState)
+sessionState = PromptIO ask
+
+runPromptIO :: PromptIO a -> IO a
+runPromptIO (PromptIO pio) =
+  (Data.IORef.newIORef newSessionState) >>= (runReaderT pio)
+
+type Inputs = NonEmpty String
+
 newtype PurePrompt a = PurePrompt
-  { _runPrompt
-      :: NonEmpty String
-      -> Either BreakException (a, NonEmpty String)
+  { runPromptState
+      :: (Inputs, SessionState)
+      -> Either BreakException (a, (Inputs, SessionState))
   }
   deriving (Functor)
 
-evalPrompt :: PurePrompt a -> NonEmpty String -> a
-evalPrompt act s = case _runPrompt act s of
+runPrompt :: PurePrompt a -> Inputs -> Either BreakException (a, Inputs)
+runPrompt act args =
+  fmap
+    (\(a, (s, _)) -> (a, s))
+    (runPromptState act (args, newSessionState))
+
+evalPrompt :: PurePrompt a -> Inputs -> a
+evalPrompt act s = case runPrompt act s of
   Left e -> error $ show e
   Right (a, _) -> a
 
@@ -306,7 +332,7 @@ instance Monad PurePrompt where
   return = pure
   PurePrompt a >>= k = PurePrompt $ \s -> case a s of
     Left e -> Left e
-    Right (a', s') -> _runPrompt (k a') s'
+    Right (a', s') -> runPromptState (k a') s'
 
 class Monad m => Interactive m where
   -- input functions
@@ -341,36 +367,61 @@ class Monad m => Interactive m where
   break :: m Bool
   throwPrompt :: BreakException -> m a
 
-instance Interactive IO where
-  getLine = P.getLine
-  readFile = P.readFile
-  getCurrentDirectory = P.getCurrentDirectory
-  getHomeDirectory = P.getHomeDirectory
-  getDirectoryContents = P.getDirectoryContents
-  listDirectory = P.listDirectory
-  doesDirectoryExist = P.doesDirectoryExist
-  doesFileExist = P.doesFileExist
-  canonicalizePathNoThrow = P.canonicalizePathNoThrow
-  readProcessWithExitCode = Process.readProcessWithExitCode
-  getEnvironment = P.getEnvironment
-  getCurrentYear = P.getCurrentYear
-  listFilesInside = P.listFilesInside
-  listFilesRecursive = P.listFilesRecursive
-
-  putStr = P.putStr
-  putStrLn = P.putStrLn
-  createDirectory = P.createDirectory
-  removeDirectory = P.removeDirectoryRecursive
-  writeFile = P.writeFile
-  removeExistingFile = P.removeExistingFile
-  copyFile = P.copyFile
-  renameDirectory = P.renameDirectory
-  hFlush = System.IO.hFlush
+  -- session state functions
+  getLastChosenLanguage :: m (Maybe String)
+  setLastChosenLanguage :: (Maybe String) -> m ()
+
+newtype SessionState = SessionState
+  { lastChosenLanguage :: (Maybe String)
+  }
+
+newSessionState :: SessionState
+newSessionState = SessionState{lastChosenLanguage = Nothing}
+
+instance Interactive PromptIO where
+  getLine = liftIO P.getLine
+  readFile = liftIO <$> P.readFile
+  getCurrentDirectory = liftIO P.getCurrentDirectory
+  getHomeDirectory = liftIO P.getHomeDirectory
+  getDirectoryContents = liftIO <$> P.getDirectoryContents
+  listDirectory = liftIO <$> P.listDirectory
+  doesDirectoryExist = liftIO <$> P.doesDirectoryExist
+  doesFileExist = liftIO <$> P.doesFileExist
+  canonicalizePathNoThrow = liftIO <$> P.canonicalizePathNoThrow
+  readProcessWithExitCode a b c = liftIO $ Process.readProcessWithExitCode a b c
+  getEnvironment = liftIO P.getEnvironment
+  getCurrentYear = liftIO P.getCurrentYear
+  listFilesInside test dir = do
+    -- test is run within a new env and not the current env
+    -- all usages of listFilesInside are pure functions actually
+    liftIO $ P.listFilesInside (\f -> liftIO $ runPromptIO (test f)) dir
+  listFilesRecursive = liftIO <$> P.listFilesRecursive
+
+  putStr = liftIO <$> P.putStr
+  putStrLn = liftIO <$> P.putStrLn
+  createDirectory = liftIO <$> P.createDirectory
+  removeDirectory = liftIO <$> P.removeDirectoryRecursive
+  writeFile a b = liftIO $ P.writeFile a b
+  removeExistingFile = liftIO <$> P.removeExistingFile
+  copyFile a b = liftIO $ P.copyFile a b
+  renameDirectory a b = liftIO $ P.renameDirectory a b
+  hFlush = liftIO <$> System.IO.hFlush
   message q severity msg
     | q == silent = pure ()
     | otherwise = putStrLn $ "[" ++ displaySeverity severity ++ "] " ++ msg
   break = return False
-  throwPrompt = throwM
+  throwPrompt = liftIO <$> throwM
+
+  getLastChosenLanguage = do
+    stateRef <- sessionState
+    liftIO $ lastChosenLanguage <$> Data.IORef.readIORef stateRef
+
+  setLastChosenLanguage value = do
+    stateRef <- sessionState
+    liftIO $
+      Data.IORef.modifyIORef
+        stateRef
+        (\state -> state{lastChosenLanguage = value})
 
 instance Interactive PurePrompt where
   getLine = pop
@@ -411,13 +462,18 @@ instance Interactive PurePrompt where
     _ -> return ()
 
   break = return True
-  throwPrompt (BreakException e) = PurePrompt $ \s ->
+  throwPrompt (BreakException e) = PurePrompt $ \(i, _) ->
     Left $
       BreakException
-        ("Error: " ++ e ++ "\nStacktrace: " ++ show s)
+        ("Error: " ++ e ++ "\nStacktrace: " ++ show i)
+
+  getLastChosenLanguage = PurePrompt $ \(i, s) ->
+    Right (lastChosenLanguage s, (i, s))
+  setLastChosenLanguage l = PurePrompt $ \(i, s) ->
+    Right ((), (i, s{lastChosenLanguage = l}))
 
 pop :: PurePrompt String
-pop = PurePrompt $ \(p :| ps) -> Right (p, fromList ps)
+pop = PurePrompt $ \(i :| is, s) -> Right (i, (fromList is, s))
 
 popAbsolute :: PurePrompt String
 popAbsolute = do
@@ -429,7 +485,7 @@ popBool =
   pop >>= \case
     "True" -> pure True
     "False" -> pure False
-    s -> throwPrompt $ BreakException $ "popBool: " ++ s
+    i -> throwPrompt $ BreakException $ "popBool: " ++ i
 
 popList :: PurePrompt [String]
 popList =