Clean up on error, fixes #1004

CHANGELOG.md

@@ -1,37 +1,5 @@
 # Revision history for ghcup
 
-## 0.1.22.0 -- ????-??-??
-
-### New features
-
-* Beef up `--overwrite-version`, fixes [#998](https://github.com/haskell/ghcup-hs/issues/998)
-  * e.g. `ghcup compile hls -g master --overwrite-version='%v-%h' --ghc 9.4.8` will produce a binary called `haskell-language-server-wrapper-<version-from-cabal-file>-<short-git-commit-hash>`... refer to `ghcup compile hls --help` for more information
-* Allow to set ghcup msys2 environment wrt [#982](https://github.com/haskell/ghcup-hs/issues/982)
-* Add mechanism to warn on new metadata versions, fixes [#860](https://github.com/haskell/ghcup-hs/issues/860)
-
-### Improvements and bug fixes
-
-* Clean up on git clone errors, fixes [#1004](https://github.com/haskell/ghcup-hs/issues/1004)
-* Error out on empty UserSettings wrt [#922](https://github.com/haskell/ghcup-hs/issues/922)
-* Fix failure mode when metadata is garbage, fixes [#921](https://github.com/haskell/ghcup-hs/issues/921)
-* Be less confusing when user tries to 'set' ghcup in TUI, fixes [#923](https://github.com/haskell/ghcup-hs/issues/923)
-* Fix prefetch for cross bindists
-* Fix misinterpretation of '+' in URI paths, fixes [#408](https://github.com/haskell/ghcup-hs/issues/408)
-* Stricter (and better) file uri handling
-* Set LD=ld.bfd on Alpine linux during bindist configure
-* Add rocky/void detection
-* Logging improvements
-* Remove the "show all tool" config in the TUI
-* Fix opening changelog on windows
-* Don't remove share dir link prematurely
-* Require user to explicitly choose subcommand for 'ghcup config'
-* Don't download twice when trying stack decoding
-
-### Refactoring and maintenance
-
-* Large TUI code cleanup by @lsmor (Luis Morillo)... more coming up soon
-* Allow building with `tar` instead of `libarchive` (mainly to make contributions easier)
-
 ## 0.1.20.0 -- 2023-11-10
 
 ### New features

ghcup.cabal

@@ -1,9 +1,9 @@
 cabal-version:      2.4
 name:               ghcup
-version:            0.1.22.0
+version:            0.1.20.0
 license:            LGPL-3.0-only
 license-file:       LICENSE
-copyright:          Julian Ospald 2024
+copyright:          Julian Ospald 2020
 maintainer:         hasufell@posteo.de
 author:             Julian Ospald
 homepage:           https://github.com/haskell/ghcup-hs

lib-opt/GHCup/OptParse/Compile.hs

@@ -529,14 +529,9 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
           HLS.SourceDist targetVer -> do
             GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
             let vi = getVersionInfo (mkTVer targetVer) HLS dls
-            forM_ (_viPreInstall =<< vi) $ \msg -> do
-              lift $ logWarn msg
-              lift $ logWarn
-                "...waiting for 5 seconds, you can still abort..."
-              liftIO $ threadDelay 5000000 -- give the user a sec to intervene
             forM_ (_viPreCompile =<< vi) $ \msg -> do
-              lift $ logWarn msg
-              lift $ logWarn
+              lift $ logInfo msg
+              lift $ logInfo
                 "...waiting for 5 seconds, you can still abort..."
               liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
           _ -> pure ()
@@ -583,14 +578,9 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
           GHC.SourceDist targetVer -> do
             GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
             let vi = getVersionInfo (mkTVer targetVer) GHC dls
-            forM_ (_viPreInstall =<< vi) $ \msg -> do
-              lift $ logWarn msg
-              lift $ logWarn
-                "...waiting for 5 seconds, you can still abort..."
-              liftIO $ threadDelay 5000000 -- give the user a sec to intervene
             forM_ (_viPreCompile =<< vi) $ \msg -> do
-              lift $ logWarn msg
-              lift $ logWarn
+              lift $ logInfo msg
+              lift $ logInfo
                 "...waiting for 5 seconds, you can still abort..."
               liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
           _ -> pure ()

lib-opt/GHCup/OptParse/Install.hs

@@ -24,7 +24,6 @@ import           GHCup.Prelude
 import           GHCup.Prelude.Logger
 import           GHCup.Prelude.String.QQ
 
-import           Control.Concurrent (threadDelay)
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
 #endif
@@ -328,11 +327,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
     (case instBindist of
        Nothing -> runInstGHC s' $ do
          (v, vi) <- liftE $ fromVersion instVer GHC
-         forM_ (_viPreInstall =<< vi) $ \msg -> do
-           lift $ logWarn msg
-           lift $ logWarn
-             "...waiting for 5 seconds, you can still abort..."
-           liftIO $ threadDelay 5000000 -- give the user a sec to intervene
          liftE $ runBothE' (installGHCBin
                      v
                      (maybe GHCupInternal IsolateDir isolateDir)
@@ -344,11 +338,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
        Just uri -> do
          runInstGHC s'{ settings = settings {noVerify = True}} $ do
            (v, vi) <- liftE $ fromVersion instVer GHC
-           forM_ (_viPreInstall =<< vi) $ \msg -> do
-             lift $ logWarn msg
-             lift $ logWarn
-               "...waiting for 5 seconds, you can still abort..."
-             liftIO $ threadDelay 5000000 -- give the user a sec to intervene
            liftE $ runBothE' (installGHCBindist
                        (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing)
                        v
@@ -410,11 +399,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
     (case instBindist of
        Nothing -> runInstTool s' $ do
          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-         forM_ (_viPreInstall =<< vi) $ \msg -> do
-           lift $ logWarn msg
-           lift $ logWarn
-             "...waiting for 5 seconds, you can still abort..."
-           liftIO $ threadDelay 5000000 -- give the user a sec to intervene
          liftE $ runBothE' (installCabalBin
                                     v
                                     (maybe GHCupInternal IsolateDir isolateDir)
@@ -424,11 +408,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
-           forM_ (_viPreInstall =<< vi) $ \msg -> do
-             lift $ logWarn msg
-             lift $ logWarn
-               "...waiting for 5 seconds, you can still abort..."
-             liftIO $ threadDelay 5000000 -- give the user a sec to intervene
            liftE $ runBothE' (installCabalBindist
                                       (DownloadInfo uri Nothing "" Nothing Nothing)
                                       v
@@ -469,11 +448,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
      (case instBindist of
        Nothing -> runInstTool s' $ do
          (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-         forM_ (_viPreInstall =<< vi) $ \msg -> do
-           lift $ logWarn msg
-           lift $ logWarn
-             "...waiting for 5 seconds, you can still abort..."
-           liftIO $ threadDelay 5000000 -- give the user a sec to intervene
          liftE $ runBothE' (installHLSBin
                                     v
                                     (maybe GHCupInternal IsolateDir isolateDir)
@@ -483,11 +457,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
        Just uri -> do
          runInstTool s'{ settings = settings { noVerify = True}} $ do
            (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
-           forM_ (_viPreInstall =<< vi) $ \msg -> do
-             lift $ logWarn msg
-             lift $ logWarn
-               "...waiting for 5 seconds, you can still abort..."
-             liftIO $ threadDelay 5000000 -- give the user a sec to intervene
            -- TODO: support legacy
            liftE $ runBothE' (installHLSBindist
                                       (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing)
@@ -529,11 +498,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
      (case instBindist of
         Nothing -> runInstTool s' $ do
           (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-          forM_ (_viPreInstall =<< vi) $ \msg -> do
-            lift $ logWarn msg
-            lift $ logWarn
-              "...waiting for 5 seconds, you can still abort..."
-            liftIO $ threadDelay 5000000 -- give the user a sec to intervene
           liftE $ runBothE' (installStackBin
                                      v
                                      (maybe GHCupInternal IsolateDir isolateDir)
@@ -543,11 +507,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
         Just uri -> do
           runInstTool s'{ settings = settings { noVerify = True}} $ do
             (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
-            forM_ (_viPreInstall =<< vi) $ \msg -> do
-              lift $ logWarn msg
-              lift $ logWarn
-                "...waiting for 5 seconds, you can still abort..."
-              liftIO $ threadDelay 5000000 -- give the user a sec to intervene
             liftE $ runBothE' (installStackBindist
                                        (DownloadInfo uri Nothing "" Nothing Nothing)
                                        v

lib-opt/GHCup/OptParse/Upgrade.hs

@@ -17,7 +17,6 @@ import           GHCup.Types
 import           GHCup.Prelude.File
 import           GHCup.Prelude.Logger
 
-import           Control.Concurrent (threadDelay)
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
 #endif
@@ -136,15 +135,8 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
     UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
 
   runUpgrade runAppState (do
+    v' <- liftE $ upgradeGHCup target force' fatal
     GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-    Just (tver, vi) <- pure $ getLatest dls GHCup
-    let latestVer = _tvVersion tver
-    forM_ (_viPreInstall vi) $ \msg -> do
-      lift $ logWarn msg
-      lift $ logWarn
-        "...waiting for 5 seconds, you can still abort..."
-      liftIO $ threadDelay 5000000 -- give the user a sec to intervene
-    v' <- liftE $ upgradeGHCup' target force' fatal latestVer
     pure (v', dls)
     ) >>= \case
       VRight (v', dls) -> do

lib/GHCup.hs

@@ -273,6 +273,7 @@ getDebugInfo = do
     --[ GHCup upgrade etc ]--
     -------------------------
 
+
 -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
 -- if no path is provided.
 upgradeGHCup :: ( MonadMask m
@@ -307,48 +308,11 @@ upgradeGHCup :: ( MonadMask m
                   m
                   Version
 upgradeGHCup mtarget force' fatal = do
-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-  let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup))
-  upgradeGHCup' mtarget force' fatal latestVer
-
-
--- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
--- if no path is provided.
-upgradeGHCup' :: ( MonadMask m
-                 , MonadReader env m
-                 , HasDirs env
-                 , HasPlatformReq env
-                 , HasGHCupInfo env
-                 , HasSettings env
-                 , MonadCatch m
-                 , HasLog env
-                 , MonadThrow m
-                 , MonadFail m
-                 , MonadResource m
-                 , MonadIO m
-                 , MonadUnliftIO m
-                 )
-              => Maybe FilePath    -- ^ full file destination to write ghcup into
-              -> Bool              -- ^ whether to force update regardless
-                                   --   of currently installed version
-              -> Bool              -- ^ whether to throw an error if ghcup is shadowed
-              -> Version
-              -> Excepts
-                   '[ CopyError
-                    , DigestError
-                    , ContentLengthError
-                    , GPGError
-                    , GPGError
-                    , DownloadFailed
-                    , NoDownload
-                    , NoUpdate
-                    , ToolShadowed
-                    ]
-                   m
-                   Version
-upgradeGHCup' mtarget force' fatal latestVer = do
   Dirs {..} <- lift getDirs
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+
   lift $ logInfo "Upgrading GHCup..."
+  let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup))
   (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
   when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
   dli   <- liftE $ getDownloadInfo GHCup latestVer

lib/GHCup/Download.hs

@@ -177,7 +177,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
    where
     fromDownloadInfo :: DownloadInfo -> VersionInfo
     fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
-                           in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing Nothing
+                           in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing
 
     fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo
     fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do

lib/GHCup/Types.hs

@@ -149,7 +149,6 @@ data VersionInfo = VersionInfo
   , _viTestDL      :: Maybe DownloadInfo -- ^ test tarball
   , _viArch        :: ArchitectureSpec   -- ^ descend for binary downloads per arch
   -- informative messages
-  , _viPreInstall  :: Maybe Text
   , _viPostInstall :: Maybe Text
   , _viPostRemove  :: Maybe Text
   , _viPreCompile  :: Maybe Text