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.Types.Optics      hiding ( toolRequirements )
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           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)
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 . (:[]) . Right) 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 --
          -------------------------


          let 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
                  -- check for new tools
                  _
                    | Just False <- optVerbose -> pure ()
                    | otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
                         Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, 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: "
                                              <> prettyVer l
                                              <> ". To upgrade, run 'ghcup upgrade'")
                                 _ -> runLogger $
                                        logWarn ("New "
                                          <> T.pack (prettyShow t)
                                          <> " version available. "
                                          <> "To upgrade, run 'ghcup install "
                                          <> T.pack (prettyShow t)
                                          <> " "
                                          <> prettyVer l
                                          <> "'")
                         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 dirs runAppState runLogger
            Config configCommand       -> config configCommand settings 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

          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, Version)
                    -> Excepts
                         '[ TagNotFound
                          , 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{ ovewrwiteVer = Just over }))
    (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver
  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))
    (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Just over }))
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer 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
       -> Version
       -> Excepts
            '[ TagNotFound
             , NextVerNotFound
             , NoToolVersionSet
             ] m Bool
  cmp' tool instVer ver = do
    (v, _) <- liftE $ fromVersion instVer tool
    pure (v == mkTVer ver)