Add viPreInstall wrt #1016

This commit is contained in:
Julian Ospald 2024-03-02 16:23:28 +08:00
parent 190d308ddf
commit aef10a699e
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
8 changed files with 21940 additions and 23428 deletions

View File

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

View File

@ -24,6 +24,7 @@ import GHCup.Prelude
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ import GHCup.Prelude.String.QQ
import Control.Concurrent (threadDelay)
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
#endif #endif
@ -327,6 +328,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of (case instBindist of
Nothing -> runInstGHC s' $ do Nothing -> runInstGHC s' $ do
(v, vi) <- liftE $ fromVersion instVer GHC (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 liftE $ runBothE' (installGHCBin
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
@ -338,6 +344,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
Just uri -> do Just uri -> do
runInstGHC s'{ settings = settings {noVerify = True}} $ do runInstGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion instVer GHC (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 liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing) (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing)
v v
@ -399,6 +410,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of (case instBindist of
Nothing -> runInstTool s' $ do Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal (_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 liftE $ runBothE' (installCabalBin
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
@ -408,6 +424,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} $ do runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal (_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 liftE $ runBothE' (installCabalBindist
(DownloadInfo uri Nothing "" Nothing Nothing) (DownloadInfo uri Nothing "" Nothing Nothing)
v v
@ -448,6 +469,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of (case instBindist of
Nothing -> runInstTool s' $ do Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS (_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 liftE $ runBothE' (installHLSBin
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
@ -457,6 +483,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} $ do runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS (_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 -- TODO: support legacy
liftE $ runBothE' (installHLSBindist liftE $ runBothE' (installHLSBindist
(DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing) (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing)
@ -498,6 +529,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of (case instBindist of
Nothing -> runInstTool s' $ do Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack (_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 liftE $ runBothE' (installStackBin
v v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
@ -507,6 +543,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
Just uri -> do Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} $ do runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack (_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 liftE $ runBothE' (installStackBindist
(DownloadInfo uri Nothing "" Nothing Nothing) (DownloadInfo uri Nothing "" Nothing Nothing)
v v

View File

@ -17,6 +17,7 @@ import GHCup.Types
import GHCup.Prelude.File import GHCup.Prelude.File
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import Control.Concurrent (threadDelay)
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
#endif #endif
@ -135,8 +136,15 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt)) UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
runUpgrade runAppState (do runUpgrade runAppState (do
v' <- liftE $ upgradeGHCup target force' fatal
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo 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) pure (v', dls)
) >>= \case ) >>= \case
VRight (v', dls) -> do VRight (v', dls) -> do

View File

@ -273,7 +273,6 @@ getDebugInfo = do
--[ GHCup upgrade etc ]-- --[ GHCup upgrade etc ]--
------------------------- -------------------------
-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided. -- if no path is provided.
upgradeGHCup :: ( MonadMask m upgradeGHCup :: ( MonadMask m
@ -308,11 +307,48 @@ upgradeGHCup :: ( MonadMask m
m m
Version Version
upgradeGHCup mtarget force' fatal = do upgradeGHCup mtarget force' fatal = do
Dirs {..} <- lift getDirs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ logInfo "Upgrading GHCup..."
let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup)) 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
lift $ logInfo "Upgrading GHCup..."
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer "" (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer dli <- liftE $ getDownloadInfo GHCup latestVer

View File

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

View File

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

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff