{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DuplicateRecordFields #-} module Main where #if defined(BRICK) import BrickMain ( brickMain ) #endif import qualified GHCup.GHC as GHC import qualified GHCup.HLS as HLS import GHCup.OptParse import GHCup.Download import GHCup.Errors import GHCup.Platform import GHCup.Types import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.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 Data.Versions 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 import qualified GHCup.Types as Types 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 downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings) mirrors = fromMaybe (Types.mirrors defaultSettings) uMirrors stackSetupSource = fromMaybe (Types.stackSetupSource defaultSettings) uStackSetupSource stackSetup = fromMaybe (Types.stackSetup defaultSettings) uStackSetup 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)) unless (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: * 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, userConf) <- toSettings opt -- logger interpreter logfile <- runReaderT initGHCupFileLogging dirs 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 -- ------------------------- 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 @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError] $ liftE getDownloadsF ) >>= \case VRight r -> pure r VLeft e -> do runLogger (logError $ T.pack $ prettyHFError e) exitWith (ExitFailure 2) let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig 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 () UnSet _ -> pure () #if defined(BRICK) Interactive -> pure () #endif -- check for new tools _ | 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: " <> tVerToText l <> ". To upgrade, run 'ghcup upgrade'") _ -> runLogger $ logWarn ("New " <> T.pack (prettyShow t) <> " version available. " <> "If you want to install this latest version, run 'ghcup install " <> T.pack (prettyShow t) <> " " <> tVerToText l <> "'") Just _ -> pure () -- TODO: always run for windows siletRunLogger (flip runReaderT s' $ runE ensureGlobalTools) >>= \case VRight _ -> pure () VLeft e -> do runLogger (logError $ T.pack $ prettyHFError 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 runReaderT action' s' ----------------- -- 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 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 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 case res of ExitSuccess -> pure () ef@(ExitFailure _) -> exitWith ef pure () where alreadyInstalling :: ( HasLog env , MonadFail m , MonadReader env m , HasGHCupInfo env , HasDirs env , MonadThrow m , MonadIO m , MonadCatch m ) => Command -> (Tool, GHCTargetVersion) -> Excepts '[ TagNotFound , DayNotFound , NextVerNotFound , NoToolVersionSet ] m Bool alreadyInstalling (Install (Right InstallGHCOptions{..})) (GHC, ver) = cmp' GHC instVer ver alreadyInstalling (Install (Left (InstallGHC InstallGHCOptions{..}))) (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{ ovewrwiteVer = Just over })) (GHC, ver) = cmp' GHC (Just $ GHCVersion (mkTVer over)) ver alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver })) (GHC, ver) = cmp' GHC (Just $ ToolVersion tver) ver alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over })) (HLS, ver) = cmp' HLS (Just $ ToolVersion over) ver alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.SourceDist tver })) (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 -> GHCTargetVersion -> Excepts '[ TagNotFound , DayNotFound , NextVerNotFound , NoToolVersionSet ] m Bool cmp' tool instVer ver = do (v, _) <- liftE $ fromVersion instVer tool pure (v == ver)