292 lines
11 KiB
Haskell
292 lines
11 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
|
|
|
|
module Main where
|
|
|
|
#if defined(BRICK)
|
|
import BrickMain ( brickMain )
|
|
#endif
|
|
|
|
import GHCup.OptParse
|
|
|
|
import GHCup.Download
|
|
import GHCup.Errors
|
|
import GHCup.Platform
|
|
import GHCup.Types
|
|
import GHCup.Utils
|
|
import GHCup.Utils.Logger
|
|
import GHCup.Utils.Prelude
|
|
import GHCup.Utils.String.QQ
|
|
import GHCup.Version
|
|
|
|
import Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
|
|
import Control.Concurrent
|
|
import Control.Concurrent.Async
|
|
import Control.Exception.Safe
|
|
#if !MIN_VERSION_base(4,13,0)
|
|
import Control.Monad.Fail ( MonadFail )
|
|
#endif
|
|
import Control.Monad.Reader
|
|
import Data.Aeson ( decodeStrict', Value )
|
|
import Data.Aeson.Encode.Pretty ( encodePretty )
|
|
import Data.Either
|
|
import Data.Functor
|
|
import Data.Maybe
|
|
import GHC.IO.Encoding
|
|
import Haskus.Utils.Variant.Excepts
|
|
import Language.Haskell.TH
|
|
import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) )
|
|
import Options.Applicative hiding ( style )
|
|
import Options.Applicative.Help.Pretty ( text )
|
|
import Prelude hiding ( appendFile )
|
|
import System.Environment
|
|
import System.Exit
|
|
import System.IO hiding ( appendFile )
|
|
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
|
|
|
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
|
|
|
|
|
|
|
|
toSettings :: Options -> IO (Settings, KeyBindings)
|
|
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 $ mergeConf options userConf noColor
|
|
where
|
|
mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings)
|
|
mergeConf Options{..} UserSettings{..} noColor =
|
|
let cache = fromMaybe (fromMaybe False uCache) optCache
|
|
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify
|
|
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose
|
|
keepDirs = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs
|
|
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
|
|
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
|
|
urlSource = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
|
|
noNetwork = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork
|
|
gpgSetting = fromMaybe (fromMaybe GPGNone uGPGSetting) optGpg
|
|
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
|
|
, bShowAllVersions = fromMaybe bShowAllVersions kShowAll
|
|
, bShowAllTools = fromMaybe bShowAllTools kShowAllTools
|
|
}
|
|
|
|
|
|
|
|
plan_json :: String
|
|
plan_json = $( do
|
|
(fp, c) <- runIO (handleIO (\_ -> pure ("", "")) $ do
|
|
fp <- findPlanJson (ProjectRelativeToDir ".")
|
|
c <- B.readFile fp
|
|
(Just res) <- pure $ decodeStrict' @Value c
|
|
pure (fp, T.unpack $ decUTF8Safe' $ encodePretty res))
|
|
when (not . null $ fp ) $ qAddDependentFile fp
|
|
pure . LitE . StringL $ c)
|
|
|
|
|
|
main :: IO ()
|
|
main = do
|
|
-- https://gitlab.haskell.org/ghc/ghc/issues/8118
|
|
setLocaleEncoding utf8
|
|
|
|
void enableAnsiSupport
|
|
|
|
let versionHelp = infoOption
|
|
( ("The GHCup Haskell installer, version " <>)
|
|
(head . lines $ describe_result)
|
|
)
|
|
(long "version" <> help "Show version" <> hidden)
|
|
let planJson = infoOption
|
|
plan_json
|
|
(long "plan-json" <> help "Show the build-time configuration" <> internal)
|
|
let numericVersionHelp = infoOption
|
|
numericVer
|
|
( long "numeric-version"
|
|
<> help "Show the numeric version (for use in scripts)"
|
|
<> hidden
|
|
)
|
|
let listCommands = infoOption
|
|
"install set rm install-cabal list upgrade compile debug-info tool-requirements changelog"
|
|
( long "list-commands"
|
|
<> help "List available commands for shell completion"
|
|
<> internal
|
|
)
|
|
|
|
let main_footer = [s|Discussion:
|
|
ghcup installs the Glasgow Haskell Compiler from the official
|
|
release channels, enabling you to easily switch between different
|
|
versions. It maintains a self-contained ~/.ghcup directory.
|
|
|
|
ENV variables:
|
|
* TMPDIR: where ghcup does the work (unpacking, building, ...)
|
|
* GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME)
|
|
* GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories
|
|
|
|
Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|
|
|
customExecParser
|
|
(prefs showHelpOnError)
|
|
(info (opts <**> helper <**> versionHelp <**> numericVersionHelp <**> planJson <**> listCommands)
|
|
(footerDoc (Just $ text main_footer))
|
|
)
|
|
>>= \opt@Options {..} -> do
|
|
dirs@Dirs{..} <- getAllDirs
|
|
|
|
-- create ~/.ghcup dir
|
|
ensureDirectories dirs
|
|
|
|
(settings, keybindings) <- toSettings opt
|
|
|
|
-- logger interpreter
|
|
logfile <- flip runReaderT dirs initGHCupFileLogging
|
|
no_color <- isJust <$> lookupEnv "NO_COLOR"
|
|
let loggerConfig = LoggerConfig
|
|
{ lcPrintDebug = verbose settings
|
|
, consoleOutter = T.hPutStr stderr
|
|
, fileOutter =
|
|
case optCommand of
|
|
Nuke -> \_ -> pure ()
|
|
_ -> T.appendFile logfile
|
|
, fancyColors = not no_color
|
|
}
|
|
let leanAppstate = LeanAppState settings dirs keybindings loggerConfig
|
|
let runLogger = flip runReaderT leanAppstate
|
|
let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { consoleOutter = \_ -> pure () } } :: LeanAppState)
|
|
|
|
|
|
-------------------------
|
|
-- Setting up appstate --
|
|
-------------------------
|
|
|
|
|
|
appState = do
|
|
pfreq <- (
|
|
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
|
|
) >>= \case
|
|
VRight r -> pure r
|
|
VLeft e -> do
|
|
runLogger
|
|
(logError $ T.pack $ prettyShow e)
|
|
exitWith (ExitFailure 2)
|
|
|
|
ghcupInfo <-
|
|
( flip runReaderT leanAppstate
|
|
. runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
|
|
$ liftE
|
|
$ getDownloadsF
|
|
)
|
|
>>= \case
|
|
VRight r -> pure r
|
|
VLeft e -> do
|
|
runLogger
|
|
(logError $ T.pack $ prettyShow e)
|
|
exitWith (ExitFailure 2)
|
|
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
|
|
|
|
race_ (liftIO $ flip runReaderT s' cleanupTrash)
|
|
(threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
|
|
|
|
case optCommand of
|
|
Nuke -> pure ()
|
|
Whereis _ _ -> pure ()
|
|
DInfo -> pure ()
|
|
ToolRequirements -> pure ()
|
|
ChangeLog _ -> pure ()
|
|
UnSet _ -> pure ()
|
|
#if defined(BRICK)
|
|
Interactive -> pure ()
|
|
#endif
|
|
_ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
|
|
Nothing -> flip runReaderT s' checkForUpdates
|
|
Just _ -> pure ()
|
|
|
|
-- TODO: always run for windows
|
|
(siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
|
|
VRight _ -> pure ()
|
|
VLeft e -> do
|
|
runLogger
|
|
(logError $ T.pack $ prettyShow e)
|
|
exitWith (ExitFailure 30)
|
|
pure s'
|
|
|
|
|
|
#if defined(IS_WINDOWS)
|
|
-- FIXME: windows needs 'ensureGlobalTools', which requires
|
|
-- full appstate
|
|
runLeanAppState = runAppState
|
|
#else
|
|
runLeanAppState = flip runReaderT leanAppstate
|
|
#endif
|
|
runAppState action' = do
|
|
s' <- liftIO appState
|
|
flip runReaderT s' action'
|
|
|
|
|
|
-----------------
|
|
-- Run command --
|
|
-----------------
|
|
|
|
res <- case optCommand of
|
|
#if defined(BRICK)
|
|
Interactive -> do
|
|
s' <- appState
|
|
liftIO $ brickMain s' >> pure ExitSuccess
|
|
#endif
|
|
Install installCommand -> install installCommand settings appState runLogger
|
|
InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) 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 runAppState runLogger
|
|
Config configCommand -> config configCommand settings keybindings runLogger
|
|
Whereis whereisOptions
|
|
whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
|
|
Upgrade uOpts force' -> upgrade uOpts force' runAppState runLogger
|
|
ToolRequirements -> toolRequirements runAppState runLogger
|
|
ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger
|
|
Nuke -> nuke appState runLogger
|
|
Prefetch pfCom -> prefetch pfCom runAppState runLogger
|
|
GC gcOpts -> gc gcOpts runAppState runLogger
|
|
|
|
case res of
|
|
ExitSuccess -> pure ()
|
|
ef@(ExitFailure _) -> exitWith ef
|
|
|
|
pure ()
|
|
|
|
|