{-# 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 |] 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 ()