ghcup-hs/app/ghcup/GHCup/OptParse/Install.hs

629 lines
25 KiB
Haskell
Raw Normal View History

2021-10-15 20:24:23 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ViewPatterns #-}
2021-10-15 20:24:23 +00:00
module GHCup.OptParse.Install where
import GHCup.OptParse.Common
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
import Codec.Archive
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Either
import Data.Functor
import Data.Maybe
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser )
2021-10-15 20:24:23 +00:00
import qualified Data.Text as T
----------------
--[ Commands ]--
----------------
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
| InstallHLS InstallOptions
| InstallStack InstallOptions
---------------
--[ Options ]--
---------------
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
, instPlatform :: Maybe PlatformRequest
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
, forceInstall :: Bool
}
---------------
--[ 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 (Either InstallCommand InstallOptions)
installParser =
(Left <$> 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)
)
)
)
)
<|> (Right <$> installOpts Nothing)
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 head fedora bindist
ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|]
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
(\p (u, v) b is f -> InstallOptions v p u b is f)
<$> optional
(option
(eitherReader platformParser)
( short 'p'
<> long "platform"
<> metavar "PLATFORM"
<> help
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
)
)
<*> ( ( (,)
<$> optional
(option
(eitherReader uriParser)
2021-10-15 20:24:23 +00:00
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist"
2022-03-04 23:46:37 +00:00
<> completer (toolDlCompleter (fromMaybe GHC tool))
2021-10-15 20:24:23 +00:00
)
)
<*> (Just <$> toolVersionArgument Nothing 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"))
2021-10-15 20:24:23 +00:00
<*> optional
(option
(eitherReader isolateParser)
( short 'i'
<> long "isolate"
<> metavar "DIR"
<> help "install in an isolated dir instead of the default one"
2022-03-04 23:46:37 +00:00
<> completer (bashCompleter "directory")
2021-10-15 20:24:23 +00:00
)
)
<*> switch
(short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)")
where
setDefault = case tool of
Nothing -> False
Just GHC -> False
Just _ -> True
2021-10-15 20:24:23 +00:00
--------------
--[ 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
, UnknownArchive
, ArchiveResult
, FileDoesNotExistError
, CopyError
, NotInstalled
, DirNotEmpty
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, GPGError
, DownloadFailed
, TarDirDoesNotExist
, NextVerNotFound
, NoToolVersionSet
, FileAlreadyExistsError
, ProcessError
, UninstallFailed
, (AlreadyInstalled, ())
, (UnknownArchive, ())
, (ArchiveResult, ())
, (FileDoesNotExistError, ())
, (CopyError, ())
, (NotInstalled, ())
, (UninstallFailed, ())
, (DirNotEmpty, ())
, (NoDownload, ())
, (BuildFailed, ())
, (TagNotFound, ())
, (DigestError, ())
, (GPGError, ())
, (DownloadFailed, ())
, (TarDirDoesNotExist, ())
, (NextVerNotFound, ())
, (NoToolVersionSet, ())
, (FileAlreadyExistsError, ())
, (ProcessError, ())
, (AlreadyInstalled, NotInstalled)
, (UnknownArchive, NotInstalled)
, (ArchiveResult, NotInstalled)
, (FileDoesNotExistError, NotInstalled)
, (CopyError, NotInstalled)
, (NotInstalled, NotInstalled)
, (DirNotEmpty, NotInstalled)
, (NoDownload, NotInstalled)
, (NotInstalled, NotInstalled)
, (UninstallFailed, NotInstalled)
, (BuildFailed, NotInstalled)
, (TagNotFound, NotInstalled)
, (DigestError, NotInstalled)
, (GPGError, NotInstalled)
, (DownloadFailed, NotInstalled)
, (TarDirDoesNotExist, NotInstalled)
, (NextVerNotFound, NotInstalled)
, (NoToolVersionSet, NotInstalled)
, (FileAlreadyExistsError, NotInstalled)
, (ProcessError, NotInstalled)
, ((), NotInstalled)
2021-10-15 20:24:23 +00:00
]
runInstTool :: AppState
-> Maybe PlatformRequest
-> Excepts InstallEffects (ResourceT (ReaderT AppState IO)) a
-> IO (VEither InstallEffects a)
runInstTool appstate' mInstPlatform =
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
. runResourceT
. runE
@InstallEffects
type InstallGHCEffects = '[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
, BuildFailed
, DirNotEmpty
, AlreadyInstalled
, UninstallFailed
, (AlreadyInstalled, NotInstalled)
, (UnknownArchive, NotInstalled)
, (ArchiveResult, NotInstalled)
, (FileDoesNotExistError, NotInstalled)
, (CopyError, NotInstalled)
, (NotInstalled, NotInstalled)
, (DirNotEmpty, NotInstalled)
, (NoDownload, NotInstalled)
, (UninstallFailed, NotInstalled)
, (BuildFailed, NotInstalled)
, (TagNotFound, NotInstalled)
, (DigestError, NotInstalled)
, (GPGError, NotInstalled)
, (DownloadFailed, NotInstalled)
, (TarDirDoesNotExist, NotInstalled)
, (NextVerNotFound, NotInstalled)
, (NoToolVersionSet, NotInstalled)
, (FileAlreadyExistsError, NotInstalled)
, (ProcessError, NotInstalled)
, (AlreadyInstalled, ())
, (UnknownArchive, ())
, (ArchiveResult, ())
, (FileDoesNotExistError, ())
, (CopyError, ())
, (NotInstalled, ())
, (DirNotEmpty, ())
, (NoDownload, ())
, (UninstallFailed, ())
, (BuildFailed, ())
, (TagNotFound, ())
, (DigestError, ())
, (GPGError, ())
, (DownloadFailed, ())
, (TarDirDoesNotExist, ())
, (NextVerNotFound, ())
, (NoToolVersionSet, ())
, (FileAlreadyExistsError, ())
, (ProcessError, ())
, ((), NotInstalled)
]
runInstGHC :: AppState
-> Maybe PlatformRequest
-> Excepts InstallGHCEffects (ResourceT (ReaderT AppState IO)) a
-> IO (VEither InstallGHCEffects a)
runInstGHC appstate' mInstPlatform =
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
. runResourceT
. runE
@InstallGHCEffects
2021-10-15 20:24:23 +00:00
-------------------
--[ Entrypoints ]--
-------------------
install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
install installCommand settings getAppState' runLogger = case installCommand of
(Right iopts) -> do
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
installGHC iopts
(Left (InstallGHC iopts)) -> installGHC iopts
(Left (InstallCabal iopts)) -> installCabal iopts
(Left (InstallHLS iopts)) -> installHLS iopts
(Left (InstallStack iopts)) -> installStack iopts
where
installGHC :: InstallOptions -> IO ExitCode
installGHC InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstGHC s' instPlatform $ do
2021-10-15 20:24:23 +00:00
(v, vi) <- liftE $ fromVersion instVer GHC
void $ liftE $ sequenceE (installGHCBin
2021-10-15 20:24:23 +00:00
(_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir)
2021-10-15 20:24:23 +00:00
forceInstall
)
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
pure vi
Just uri -> do
runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer GHC
void $ liftE $ sequenceE (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
)
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
2021-10-15 20:24:23 +00:00
pure vi
)
>>= \case
VRight vi -> do
runLogger $ logInfo "GHC installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v, ())) -> do
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
pure ExitSuccess
2021-10-15 20:24:23 +00:00
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
2021-10-15 20:24:23 +00:00
pure ExitSuccess
2021-10-15 20:24:23 +00:00
VLeft (V (DirNotEmpty fp)) -> do
runLogger $ logError $
"Install directory " <> T.pack fp <> " is not empty."
2021-10-15 20:24:23 +00:00
pure $ ExitFailure 3
VLeft (V (DirNotEmpty fp, ())) -> do
runLogger $ logError $
"Install directory " <> T.pack fp <> " is not empty."
pure $ ExitFailure 3
2021-10-15 20:24:23 +00:00
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack 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 err@(V (BuildFailed tmpdir _, ())) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3
2021-10-15 20:24:23 +00:00
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 3
installCabal :: InstallOptions -> IO ExitCode
installCabal InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstTool s' instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
void $ liftE $ sequenceE (installCabalBin
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
2021-10-15 20:24:23 +00:00
pure vi
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
void $ liftE $ sequenceE (installCabalBindist
(DownloadInfo uri Nothing "")
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
2021-10-15 20:24:23 +00:00
pure vi
)
>>= \case
VRight vi -> do
runLogger $ logInfo "Cabal installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft (V (AlreadyInstalled _ v, ())) -> do
runLogger $ logWarn $
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp, ())) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
2021-10-15 20:24:23 +00:00
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
installHLS :: InstallOptions -> IO ExitCode
installHLS InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstTool s' instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
void $ liftE $ sequenceE (installHLSBin
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
2021-10-15 20:24:23 +00:00
pure vi
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
2022-02-05 00:53:04 +00:00
-- TODO: support legacy
void $ liftE $ sequenceE (installHLSBindist
(DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
2021-10-15 20:24:23 +00:00
pure vi
)
>>= \case
VRight vi -> do
runLogger $ logInfo "HLS installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
<> prettyVer v
<> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft (V (AlreadyInstalled _ v, ())) -> do
runLogger $ logWarn $
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "
<> prettyVer v
<> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp, ())) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
2021-10-15 20:24:23 +00:00
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
installStack :: InstallOptions -> IO ExitCode
installStack InstallOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of
Nothing -> runInstTool s' instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
void $ liftE $ sequenceE (installStackBin
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
2021-10-15 20:24:23 +00:00
pure vi
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
void $ liftE $ sequenceE (installStackBindist
(DownloadInfo uri Nothing "")
v
(maybe GHCupInternal IsolateDir isolateDir)
forceInstall
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
2021-10-15 20:24:23 +00:00
pure vi
)
>>= \case
VRight vi -> do
runLogger $ logInfo "Stack installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ logWarn $
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp)) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
VLeft (V (AlreadyInstalled _ v, ())) -> do
runLogger $ logWarn $
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"
pure ExitSuccess
VLeft (V (FileAlreadyExistsError fp, ())) -> do
runLogger $ logWarn $
"File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite."
pure $ ExitFailure 3
2021-10-15 20:24:23 +00:00
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4