ghcup-hs/app/ghcup/Main.hs

383 lines
17 KiB
Haskell
Raw Normal View History

2020-04-09 17:53:22 +00:00
{-# LANGUAGE CPP #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Main where
2020-07-06 20:39:16 +00:00
#if defined(BRICK)
2024-01-10 06:14:59 +00:00
-- import BrickMain ( brickMain )
import GHCup.BrickMain (brickMain)
2020-07-06 20:39:16 +00:00
#endif
import qualified GHCup.GHC as GHC
import qualified GHCup.HLS as HLS
2021-10-15 20:24:23 +00:00
import GHCup.OptParse
2020-01-11 20:15:05 +00:00
import GHCup.Download
import GHCup.Errors
2020-04-10 15:36:27 +00:00
import GHCup.Platform
2020-01-11 20:15:05 +00:00
import GHCup.Types
import GHCup.Types.Optics hiding ( toolRequirements )
2020-01-11 20:15:05 +00:00
import GHCup.Utils
2022-05-21 20:54:18 +00:00
import GHCup.Prelude
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
2020-01-11 20:15:05 +00:00
import GHCup.Version
2021-08-27 12:37:44 +00:00
import Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception.Safe
2020-04-09 17:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-01-11 20:15:05 +00:00
import Control.Monad.Reader
2021-08-27 12:37:44 +00:00
import Data.Aeson ( decodeStrict', Value )
import Data.Aeson.Encode.Pretty ( encodePretty )
2020-03-09 21:21:22 +00:00
import Data.Either
2020-03-17 00:58:59 +00:00
import Data.Functor
import Data.Versions (version)
import Data.Maybe
import GHC.IO.Encoding
2020-01-11 20:15:05 +00:00
import Haskus.Utils.Variant.Excepts
2020-04-17 14:56:56 +00:00
import Language.Haskell.TH
2021-09-04 13:10:07 +00:00
import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) )
2020-01-11 20:15:05 +00:00
import Options.Applicative hiding ( style )
2020-04-17 20:11:41 +00:00
import Options.Applicative.Help.Pretty ( text )
2020-01-11 20:15:05 +00:00
import Prelude hiding ( appendFile )
import System.Environment
import System.Exit
import System.IO hiding ( appendFile )
import Text.PrettyPrint.HughesPJClass ( prettyShow )
2020-01-11 20:15:05 +00:00
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified GHCup.Types as Types
2020-04-25 10:06:41 +00:00
2020-03-17 00:58:59 +00:00
2021-09-20 20:24:20 +00:00
toSettings :: Options -> IO (Settings, KeyBindings, UserSettings)
toSettings options = do
noColor <- isJust <$> lookupEnv "NO_COLOR"
userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
VRight r -> pure r
VLeft (V (JSONDecodeError e)) -> do
B.hPut stderr ("Error decoding config file: " <> (E.encodeUtf8 . T.pack . show $ e))
pure defaultUserSettings
_ -> do
die "Unexpected error!"
pure $ (\(s', k) -> (s', k, userConf)) $ mergeConf options userConf noColor
where
mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings)
mergeConf Options{..} UserSettings{..} noColor =
let cache = fromMaybe (fromMaybe (Types.cache defaultSettings) uCache) optCache
metaCache = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache
metaMode = fromMaybe (fromMaybe (Types.metaMode defaultSettings) uMetaMode) optMetaMode
noVerify = fromMaybe (fromMaybe (Types.noVerify defaultSettings) uNoVerify) optNoVerify
verbose = fromMaybe (fromMaybe (Types.verbose defaultSettings) uVerbose) optVerbose
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
2020-10-25 13:17:17 +00:00
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
urlSource = fromMaybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) optUrlSource
noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
2022-12-03 16:15:13 +00:00
mirrors = fromMaybe (Types.mirrors defaultSettings) uMirrors
2021-05-14 21:09:45 +00:00
in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal
#else
defaultDownloader = Curl
#endif
mergeKeys :: UserKeyBindings -> KeyBindings
mergeKeys UserKeyBindings {..} =
let KeyBindings {..} = defaultKeyBindings
in KeyBindings {
bUp = fromMaybe bUp kUp
, bDown = fromMaybe bDown kDown
, bQuit = fromMaybe bQuit kQuit
, bInstall = fromMaybe bInstall kInstall
, bUninstall = fromMaybe bUninstall kUninstall
, bSet = fromMaybe bSet kSet
, bChangelog = fromMaybe bChangelog kChangelog
2021-05-14 22:31:36 +00:00
, bShowAllVersions = fromMaybe bShowAllVersions kShowAll
}
2020-01-11 20:15:05 +00:00
2021-08-27 12:37:44 +00:00
plan_json :: String
2021-09-04 13:27:57 +00:00
plan_json = $( do
(fp, c) <- runIO (handleIO (\_ -> pure ("", "")) $ do
2021-08-27 12:37:44 +00:00
fp <- findPlanJson (ProjectRelativeToDir ".")
c <- B.readFile fp
(Just res) <- pure $ decodeStrict' @Value c
2021-09-04 13:27:57 +00:00
pure (fp, T.unpack $ decUTF8Safe' $ encodePretty res))
2021-10-15 20:24:23 +00:00
unless (null fp) $ qAddDependentFile fp
2021-09-04 13:27:57 +00:00
pure . LitE . StringL $ c)
2021-08-27 12:37:44 +00:00
2020-01-11 20:15:05 +00:00
main :: IO ()
main = do
2021-05-14 21:09:45 +00:00
-- https://gitlab.haskell.org/ghc/ghc/issues/8118
setLocaleEncoding utf8
void enableAnsiSupport
2020-04-17 16:54:21 +00:00
let versionHelp = infoOption
2021-10-15 20:24:23 +00:00
( "The GHCup Haskell installer, version " <> (head . lines $ describe_result)
2020-04-17 16:54:21 +00:00
)
2020-04-17 20:11:41 +00:00
(long "version" <> help "Show version" <> hidden)
2021-08-27 12:37:44 +00:00
let planJson = infoOption
plan_json
(long "plan-json" <> help "Show the build-time configuration" <> internal)
2020-04-17 14:56:56 +00:00
let numericVersionHelp = infoOption
numericVer
( long "numeric-version"
<> help "Show the numeric version (for use in scripts)"
2020-04-17 20:11:41 +00:00
<> hidden
2020-04-17 14:56:56 +00:00
)
2020-04-22 18:12:57 +00:00
let listCommands = infoOption
("install set rm install-cabal list"
<> " upgrade"
<> " compile debug-info tool-requirements changelog"
)
2020-04-22 18:12:57 +00:00
( long "list-commands"
<> help "List available commands for shell completion"
<> internal
)
2020-01-11 20:15:05 +00:00
2020-07-04 19:49:59 +00:00
let main_footer = [s|Discussion:
2020-04-17 20:11:41 +00:00
ghcup installs the Glasgow Haskell Compiler from the official
release channels, enabling you to easily switch between different
2020-04-22 14:14:10 +00:00
versions. It maintains a self-contained ~/.ghcup directory.
ENV variables:
* GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME)
2020-10-25 09:54:57 +00:00
* GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories
2020-04-17 20:11:41 +00:00
2022-11-22 11:06:12 +00:00
Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
2020-04-17 20:11:41 +00:00
2020-04-17 14:56:56 +00:00
customExecParser
(prefs showHelpOnError)
2021-08-27 12:37:44 +00:00
(info (opts <**> helper <**> versionHelp <**> numericVersionHelp <**> planJson <**> listCommands)
(footerDoc (Just $ text main_footer))
)
2020-01-11 20:15:05 +00:00
>>= \opt@Options {..} -> do
dirs@Dirs{..} <- getAllDirs
2021-05-14 21:09:45 +00:00
2020-03-17 18:16:21 +00:00
-- create ~/.ghcup dir
2021-06-13 11:41:06 +00:00
ensureDirectories dirs
(settings, keybindings, userConf) <- toSettings opt
2020-03-17 18:16:21 +00:00
2020-01-11 20:15:05 +00:00
-- logger interpreter
2021-10-15 20:24:23 +00:00
logfile <- runReaderT initGHCupFileLogging dirs
no_color <- isJust <$> lookupEnv "NO_COLOR"
2020-07-06 20:39:16 +00:00
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, consoleOutter = T.hPutStr stderr
, fileOutter =
2021-07-02 21:26:07 +00:00
case optCommand of
Nuke -> \_ -> pure ()
2021-08-30 20:41:58 +00:00
_ -> T.appendFile logfile
, fancyColors = not no_color
2020-01-11 20:15:05 +00:00
}
2021-08-30 20:41:58 +00:00
let leanAppstate = LeanAppState settings dirs keybindings loggerConfig
let runLogger = flip runReaderT leanAppstate
let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { consoleOutter = \_ -> pure () } } :: LeanAppState)
2021-05-14 21:09:45 +00:00
2021-07-15 11:32:48 +00:00
-------------------------
-- Setting up appstate --
-------------------------
let appState = do
pfreq <- case platformOverride settings of
Just pfreq' -> return pfreq'
Nothing -> (runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
(logError $ T.pack $ prettyHFError e)
exitWith (ExitFailure 2)
ghcupInfo <-
( flip runReaderT leanAppstate . runE @'[ContentLengthError, DigestError, DistroNotFound, DownloadFailed, FileDoesNotExistError, GPGError, JSONError, NoCompatibleArch, NoCompatiblePlatform, NoDownload, GHCup.Errors.ParseError, ProcessError, UnsupportedSetupCombo, StackPlatformDetectError] $ do
liftE $ getDownloadsF pfreq
)
>>= \case
VRight r -> pure r
VLeft e -> do
runLogger
(logError $ T.pack $ prettyHFError e)
exitWith (ExitFailure 2)
2021-08-30 20:41:58 +00:00
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
2021-05-14 21:09:45 +00:00
2021-10-15 20:24:23 +00:00
race_ (liftIO $ runReaderT cleanupTrash s')
(threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack (fromGHCupPath recycleDir) <> " manually"))
case optCommand of
Nuke -> pure ()
Whereis _ _ -> pure ()
DInfo -> pure ()
ToolRequirements _ -> pure ()
ChangeLog _ -> pure ()
2021-09-27 10:52:45 +00:00
UnSet _ -> pure ()
#if defined(BRICK)
Interactive -> pure ()
#endif
-- check for new tools
2022-03-17 20:11:39 +00:00
_
| Just False <- optVerbose -> pure ()
| otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, DayNotFound, NextVerNotFound, NoToolVersionSet] $ do
newTools <- lift checkForUpdates
forM_ newTools $ \newTool@(t, l) -> do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283
alreadyInstalling' <- alreadyInstalling optCommand newTool
when (not alreadyInstalling') $
case t of
GHCup -> runLogger $
logWarn ("New GHCup version available: "
2023-07-07 08:41:58 +00:00
<> tVerToText l
<> ". To upgrade, run 'ghcup upgrade'")
_ -> runLogger $
logWarn ("New "
<> T.pack (prettyShow t)
<> " version available. "
2022-12-20 13:49:26 +00:00
<> "If you want to install this latest version, run 'ghcup install "
<> T.pack (prettyShow t)
<> " "
2023-07-07 08:41:58 +00:00
<> tVerToText l
<> "'")
Just _ -> pure ()
2021-07-15 11:32:48 +00:00
-- TODO: always run for windows
2023-11-13 07:37:36 +00:00
siletRunLogger (flip runReaderT s' $ runE ensureShimGen) >>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
(logError $ T.pack $ prettyHFError e)
exitWith (ExitFailure 30)
pure s'
2021-07-15 11:32:48 +00:00
2021-05-14 21:09:45 +00:00
2021-07-18 21:29:09 +00:00
#if defined(IS_WINDOWS)
-- FIXME: windows needs 'ensureGlobalTools', which requires
-- full appstate
runLeanAppState = runAppState
#else
runLeanAppState = flip runReaderT leanAppstate
2021-07-18 21:29:09 +00:00
#endif
runAppState action' = do
s' <- liftIO appState
2021-10-15 20:24:23 +00:00
runReaderT action' s'
2021-05-14 21:09:45 +00:00
2021-10-15 20:24:23 +00:00
-----------------
-- Run command --
-----------------
res <- case optCommand of
2020-07-06 20:39:16 +00:00
#if defined(BRICK)
2021-05-14 21:09:45 +00:00
Interactive -> do
2021-07-18 21:29:09 +00:00
s' <- appState
2021-08-30 20:41:58 +00:00
liftIO $ brickMain s' >> pure ExitSuccess
2020-07-06 20:39:16 +00:00
#endif
Install installCommand -> install installCommand settings appState runLogger
InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger
Test testCommand -> test testCommand settings appState runLogger
Set setCommand -> set setCommand runAppState runLeanAppState runLogger
UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger
List lo -> list lo no_color runAppState
Rm rmCommand -> rm rmCommand runAppState runLogger
DInfo -> dinfo runAppState runLogger
Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger
Config configCommand -> config configCommand settings userConf keybindings runLogger
2021-10-15 20:24:23 +00:00
Whereis whereisOptions
whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger
ToolRequirements topts -> toolRequirements topts runAppState runLogger
ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger
Nuke -> nuke appState runLogger
Prefetch pfCom -> prefetch pfCom runAppState runLogger
GC gcOpts -> gc gcOpts runAppState runLogger
Run runCommand -> run runCommand appState leanAppstate runLogger
PrintAppErrors -> putStrLn allHFError >> pure ExitSuccess
2020-04-17 16:26:55 +00:00
case res of
ExitSuccess -> pure ()
2020-04-17 18:50:23 +00:00
ef@(ExitFailure _) -> exitWith ef
2020-01-11 20:15:05 +00:00
pure ()
where
alreadyInstalling :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Command
2023-07-07 08:41:58 +00:00
-> (Tool, GHCTargetVersion)
-> Excepts
'[ TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
] m Bool
alreadyInstalling (Install (Right InstallOptions{..})) (GHC, ver) = cmp' GHC instVer ver
alreadyInstalling (Install (Left (InstallGHC InstallOptions{..}))) (GHC, ver) = cmp' GHC instVer ver
alreadyInstalling (Install (Left (InstallCabal InstallOptions{..}))) (Cabal, ver) = cmp' Cabal instVer ver
alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver
alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver
alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ overwriteVer = Just [S over] })) (GHC, ver)
| Right over' <- version (T.pack over) = cmp' GHC (Just $ GHCVersion (mkTVer over')) ver
| otherwise = pure False
alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver }))
(GHC, ver) = cmp' GHC (Just $ ToolVersion tver) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ overwriteVer = Just [S over] })) (HLS, ver)
| Right over' <- version (T.pack over) = cmp' HLS (Just $ ToolVersion over') ver
| otherwise = pure False
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.SourceDist tver }))
2022-07-11 22:10:17 +00:00
(HLS, ver) = cmp' HLS (Just $ ToolVersion tver) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.HackageDist tver }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion tver) ver
alreadyInstalling (Upgrade {}) (GHCup, _) = pure True
alreadyInstalling _ _ = pure False
cmp' :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
, HasDirs env
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Tool
-> Maybe ToolVersion
2023-07-07 08:41:58 +00:00
-> GHCTargetVersion
-> Excepts
'[ TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
] m Bool
cmp' tool instVer ver = do
(v, _) <- liftE $ fromVersion instVer tool
2023-07-07 08:41:58 +00:00
pure (v == ver)