ghcup-0.2.5.0: lib-opt/GHCup/OptParse/Install.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.OptParse.Install where
import GHCup.Command.Install
import GHCup.Command.Set
import GHCup.Errors
import GHCup.Input.Parsers
( installTargetParser
, isolateParser
, resolveVersion
, toolParser
, uriParser
)
import GHCup.OptParse.Common
import GHCup.Prelude
import GHCup.Prelude.String.QQ
import GHCup.Query.GHCupDirs
import GHCup.Query.Metadata
import GHCup.Types
import GHCup.Types.Optics
import Control.Concurrent ( threadDelay )
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad ( forM_, when )
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Data.Either
import Data.Variant.Excepts
import Options.Applicative hiding ( style )
import Options.Applicative.Pretty.Shim ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
----------------
--[ Commands ]--
----------------
data InstallCommand
= InstallGHC InstallOptions
| InstallCabal InstallOptions
| InstallHLS InstallOptions
| InstallStack InstallOptions
| InstallOtherTool InstallOptionsNew
deriving (Eq, Show)
---------------
--[ Options ]--
---------------
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
, forceInstall :: Bool
, installTargets :: Maybe [String]
, addConfArgs :: [String]
}
deriving (Eq, Show)
data InstallOptionsNew = InstallOptionsNew
{ instTool :: Tool
, instVer :: Maybe ToolVersion
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
, forceInstall :: Bool
, installTargets :: Maybe [String]
, addConfArgs :: [String]
}
deriving (Eq, Show)
---------------
--[ Footers ]--
---------------
installCabalFooter :: String
installCabalFooter = [s|Discussion:
Installs the specified cabal-install version (or a recommended default one)
into "~/.ghcup/bin", so it can be overwritten by later
"cabal install cabal-install", which installs into "~/.cabal/bin" by
default. Make sure to set up your PATH appropriately, so the cabal
installation takes precedence.|]
---------------
--[ Parsers ]--
---------------
installParser :: Parser InstallCommand
installParser =
subparser
( command
"ghc"
( InstallGHC
<$> info
(installOpts (Just ghc) <**> helper)
( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter)
)
)
<> command
"cabal"
( InstallCabal
<$> info
(installOpts (Just cabal) <**> helper)
( progDesc "Install Cabal"
<> footerDoc (Just $ text installCabalFooter)
)
)
<> command
"hls"
( InstallHLS
<$> info
(installOpts (Just hls) <**> helper)
( progDesc "Install haskell-language-server"
<> footerDoc (Just $ text installHLSFooter)
)
)
<> command
"stack"
( InstallStack
<$> info
(installOpts (Just stack) <**> helper)
( progDesc "Install stack"
<> footerDoc (Just $ text installStackFooter)
)
)
)
<|> ( InstallOtherTool
<$> installOptsNew
)
where
installHLSFooter :: String
installHLSFooter = [s|Discussion:
Installs haskell-language-server binaries and wrapper
into "~/.ghcup/bin"
Examples:
# install recommended HLS
ghcup install hls|]
installStackFooter :: String
installStackFooter = [s|Discussion:
Installs stack binaries into "~/.ghcup/bin"
Examples:
# install recommended Stack
ghcup install stack|]
installGHCFooter :: String
installGHCFooter = [s|Discussion:
Installs the specified GHC version (or a recommended default one) into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
Examples:
# install recommended GHC
ghcup install ghc
# install latest GHC
ghcup install ghc latest
# install GHC 8.10.2
ghcup install ghc 8.10.2
# install GHC 8.10.2 from vanilla channel
ghcup -s vanilla install ghc 8.10.2
# install GHC head fedora bindist
ghcup install ghc -u 'https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz?job=x86_64-linux-fedora33-release' head|]
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
(\(u, v) b is f -> InstallOptions v u b is f)
<$> ( ( (,)
<$> optional
(option
(eitherReader uriParser)
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist"
<> completer (toolDlCompleter (fromMaybe ghc tool))
)
)
<*> (Just <$> toolVersionTagArgument [] tool)
)
<|> pure (Nothing, Nothing)
)
<*> fmap (fromMaybe setDefault) (invertableSwitch "set" Nothing setDefault
(help $ if not setDefault then "Set as active version after install" else "Don't set as active version after install"))
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated absolute directory instead of the default one"
<> completer (bashCompleter "directory")
)
)
<*> switch
(short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)")
<*> optional (option (eitherReader installTargetParser)
( long "install-targets"
<> metavar "TARGETS"
<> help "Overwrite make based install targets"
<> completer (listCompleter ["install", "install_bin", "install_lib", "install_extra", "install_man", "install_docs", "install_data", "update_package_db"])
)
)
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to bindist configure, prefix with '-- ' (longopts)"))
where
setDefault = case tool of
Nothing -> False
Just (Tool "ghc") -> False
Just _ -> True
installOptsNew :: Parser InstallOptionsNew
installOptsNew =
(\t (u, v) -> InstallOptionsNew t v u)
<$> argument (eitherReader toolParser) (metavar "TOOL" <> help "Which tool to install")
<*> ( ( (,)
<$> optional
(option
(eitherReader uriParser)
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist"
)
)
<*> (Just <$> toolVersionTagArgument [] Nothing)
)
<|> pure (Nothing, Nothing)
)
<*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False
(help "Set as active version after install"))
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated absolute directory instead of the default one"
<> completer (bashCompleter "directory")
)
)
<*> switch
(short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)")
<*> optional (option (eitherReader installTargetParser)
( long "install-targets"
<> metavar "TARGETS"
<> help "Overwrite make based install targets"
<> completer (listCompleter ["install", "install_bin", "install_lib", "install_extra", "install_man", "install_docs", "install_data", "update_package_db"])
)
)
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to bindist configure, prefix with '-- ' (longopts)"))
--------------
--[ Footer ]--
--------------
installToolFooter :: String
installToolFooter = [s|Discussion:
Installs GHC or cabal. When no command is given, installs GHC
with the specified version/tag.
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type InstallEffects = '[ AlreadyInstalled
, ArchiveResult
, BuildFailed
, CopyError
, DigestError
, ContentLengthError
, DirNotEmpty
, DownloadFailed
, FileAlreadyExistsError
, FileDoesNotExistError
, GPGError
, MergeFileTreeError
, NextVerNotFound
, NoDownload
, NoToolVersionSet
, NotInstalled
, ProcessError
, TagNotFound
, DayNotFound
, TarDirDoesNotExist
, UninstallFailed
, UnknownArchive
, InstallSetError
, NoCompatiblePlatform
, GHCup.Errors.ParseError
, UnsupportedSetupCombo
, DistroNotFound
, NoCompatibleArch
, URIParseError
, NoInstallInfo
, GHCup.Errors.ParseError
, MalformedInstallInfo
, InvalidBuildConfig
]
-------------------
--[ Entrypoints ]--
-------------------
install :: InstallCommand -> Settings -> (IO (AppState, IO ()), LeanAppState) -> IO ExitCode
install installCommand settings (getAppState', leanAppstate) = case installCommand of
(InstallGHC iGHCopts) -> installOther (toInstallOptionsNew ghc iGHCopts)
(InstallCabal iopts) -> installOther (toInstallOptionsNew cabal iopts)
(InstallHLS iopts) -> installOther (toInstallOptionsNew hls iopts)
(InstallStack iopts) -> installOther (toInstallOptionsNew stack iopts)
(InstallOtherTool iopts) -> installOther iopts
where
guessMode = if guessVersion settings then GLax else GStrict
toInstallOptionsNew instTool InstallOptions{..} = InstallOptionsNew{..}
installOther :: InstallOptionsNew -> IO ExitCode
installOther InstallOptionsNew{..} = do
(s'@AppState{ dirs = Dirs{ .. } }, updateCheckAction) <- getAppState'
(case instBindist of
Nothing -> run s' $ do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
treq@(TargetVersionReq tver _) <- liftE $ resolveVersion instVer guessMode instTool
let vm = getVersionMetadata tver instTool dls
forM_ (_vmPreInstall =<< vm) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
-- TODO: install targets
liftE $ runBothE' (installTool
instTool
treq
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
addConfArgs
installTargets
) $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setToolVersion instTool tver
pure vm
Just uri -> do
run s'{ settings = settings {noVerify = True}} $ do
pfreq <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
(TargetVersionReq tver _) <- liftE $ resolveVersion instVer guessMode instTool
let vm = getVersionMetadata tver instTool dls
forM_ (_vmPreInstall =<< vm) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
liftE $ runBothE' (do
rev <- fmap (fmap fst . veitherToEither) $ runE $ getDownloadInfoE' instTool (TargetVersionReq tver Nothing)
installBindist
instTool
Nothing
(DownloadInfo ((decUTF8Safe . serializeURIRef') uri) regexDir "" Nothing Nothing Nothing (toInstallationInputSpec <$> defaultToolInstallSpec instTool pfreq tver))
(TargetVersionRev tver (fromRight 0 rev))
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
addConfArgs
installTargets
)
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setToolVersion instTool tver
pure vm
)
>>= \case
VRight vm -> do
runLogger $ logInfo $ T.pack (prettyShow instTool) <> " installation successful"
forM_ (_vmPostInstall =<< vm) $ \msg ->
runLogger $ logInfo msg
liftIO updateCheckAction
pure ExitSuccess
VLeft e@(V (AlreadyInstalled _ _)) -> do
runLogger $ logWarn $ T.pack $ prettyHFError e
liftIO updateCheckAction
pure ExitSuccess
VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logError $
"Install directory " <> T.pack fp <> " is not empty."
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyHFError err)
_ -> runLogger (logError $ T.pack (prettyHFError err) <> "\n" <>
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 3
where
run appstate' =
flip runReaderT (appstate' :: AppState)
. runResourceT
. runE
@InstallEffects
runLogger = flip runReaderT leanAppstate
regexDir = case instTool of
(Tool "ghc") -> Just $ RegexDir "ghc-.*"
(Tool "cabal") -> Nothing
(Tool "stack") -> Nothing
(Tool "hls") -> if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")
_ -> Nothing -- TODO