ghcup-hs/app/ghcup/Main.hs

{-# 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           GHCup.OptParse

import           GHCup.Download
import           GHCup.Errors
import           GHCup.Platform
import           GHCup.Types
import           GHCup.Utils
import           GHCup.Logger
import           GHCup.Prelude
import           GHCup.QQ.String
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
import qualified GHCup.Types                   as Types



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 (Types.cache defaultSettings) uCache) optCache
         metaCache   = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache
         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 optUrlSource
         noNetwork   = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
         gpgSetting  = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) 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))
                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:
  * 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 <- 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 --
          -------------------------


              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 $ runReaderT cleanupTrash s')
                      (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 -> runReaderT checkForUpdates s'
                         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
                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
            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 ()