Merge branch 'master' into mergify-release-branches

.github/workflows/changelogs.yml

@@ -28,7 +28,8 @@ jobs:
 
       - name: Install changelog-d
         run: |
-          curl --create-dirs -o "$HOME/.local/bin/changelog-d" "https://codeberg.org/fgaz/changelog-d/releases/download/v1.0/changelog-d-v1.0-x86_64-linux"
+          curl --create-dirs -o "$HOME/.local/bin/changelog-d" -sS --fail \
+            "https://codeberg.org/fgaz/changelog-d/releases/download/v1.0.1/changelog-d-v1.0.1-x86_64-linux"
           chmod +x "$HOME/.local/bin/changelog-d"
           # https://docs.github.com/en/actions/using-workflows/workflow-commands-for-github-actions#adding-a-system-path
           echo "$HOME/.local/bin" >> $GITHUB_PATH

.gitignore

@@ -41,6 +41,7 @@ _build
 *~
 .*.swp
 *.bak
+.vscode
 
 # GHC build
 

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 =

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

@@ -99,7 +99,7 @@ import System.IO.Error
 
 import Distribution.Client.Compat.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink)
 import Distribution.Client.Init.Prompt (promptYesNo)
-import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt))
+import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt), runPromptIO)
 import Distribution.Client.Types.OverwritePolicy
 
 import qualified Data.ByteString as BS
@@ -336,7 +336,7 @@ symlinkBinary inputs@Symlink{publicBindir, privateBindir, publicName, privateNam
 
 promptRun :: String -> IO Bool -> IO Bool
 promptRun s m = do
-  a <- promptYesNo s MandatoryPrompt
+  a <- runPromptIO $ promptYesNo s MandatoryPrompt
   if a then m else pure a
 
 -- | Check a file path of a symlink that we would like to create to see if it

cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs

@@ -26,7 +26,7 @@ import Distribution.Simple.LocalBuildInfo
   )
 
 import qualified Data.Set as Set
-import Distribution.Client.Init.Types (removeExistingFile)
+import Distribution.Client.Init.Types (removeExistingFile, runPromptIO)
 
 -----------------------------
 -- Package change detection
@@ -291,4 +291,4 @@ updatePackageRegFileMonitor
 
 invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
 invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
-  removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)
+  runPromptIO $ removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)

cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs

@@ -81,7 +81,7 @@ tests _v _initFlags comp pkgIx srcDb =
                 "False"
               ]
 
-        case flip _runPrompt inputs $ do
+        case flip runPrompt inputs $ do
           projSettings <- createProject comp silent pkgIx srcDb dummyFlags'
           writeProject projSettings of
           Left (BreakException ex) -> assertFailure $ show ex