hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add viPreInstall wrt #1016

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
lib-opt/GHCup/OptParse/Compile.hs
View File

@ -529,9 +529,14 @@ 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 $ logInfo msg
lift $ logInfo
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure ()
@ -578,9 +583,14 @@ 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 $ logInfo msg
lift $ logInfo
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure ()

41
lib-opt/GHCup/OptParse/Install.hs
View File

@ -24,6 +24,7 @@ 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
@ -327,6 +328,11 @@ 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)
@ -338,6 +344,11 @@ 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
@ -399,6 +410,11 @@ 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)
@ -408,6 +424,11 @@ 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
@ -448,6 +469,11 @@ 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)
@ -457,6 +483,11 @@ 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)
@ -498,6 +529,11 @@ 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)
@ -507,6 +543,11 @@ 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

10
lib-opt/GHCup/OptParse/Upgrade.hs
View File

@ -17,6 +17,7 @@ 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
@ -135,8 +136,15 @@ 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

44
lib/GHCup.hs
View File

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

2
lib/GHCup/Download.hs
View File

@ -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
in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing Nothing
fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo
fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do

1
lib/GHCup/Types.hs
View File

@ -149,6 +149,7 @@ 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

22626
test/ghcup-test/golden/unix/GHCupInfo.json
View File

File diff suppressed because it is too large Load Diff

22626
test/ghcup-test/golden/windows/GHCupInfo.json
View File

File diff suppressed because it is too large Load Diff