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

493 lines
17 KiB
Haskell
Raw Permalink Normal View History

2022-02-09 17:57:59 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
2022-02-09 17:57:59 +00:00
module GHCup.OptParse.Run where
import GHCup
import GHCup.Utils
import GHCup.OptParse.Common
import GHCup.Errors
import GHCup.Types
2022-03-17 23:42:48 +00:00
import GHCup.Types.Optics
2022-05-21 20:54:18 +00:00
import GHCup.Prelude
import GHCup.Prelude.File
#ifdef IS_WINDOWS
import GHCup.Prelude.Process
2022-06-06 21:02:21 +00:00
import GHCup.Prelude.Process.Windows ( execNoMinGW )
2022-05-21 20:54:18 +00:00
#endif
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
2022-02-09 17:57:59 +00:00
import Control.Exception.Safe ( MonadMask, MonadCatch )
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Codec.Archive
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe (isNothing)
import Data.List ( intercalate )
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.FilePath
import System.Environment
import System.Exit
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
#ifndef IS_WINDOWS
import qualified System.Posix.Process as SPP
#endif
import Data.Versions ( prettyVer, Version )
2022-02-09 17:57:59 +00:00
---------------
--[ Options ]--
---------------
data RunOptions = RunOptions
{ runAppendPATH :: Bool
, runInstTool' :: Bool
2022-06-06 21:02:21 +00:00
, runMinGWPath :: Bool
2022-02-09 17:57:59 +00:00
, runGHCVer :: Maybe ToolVersion
, runCabalVer :: Maybe ToolVersion
, runHLSVer :: Maybe ToolVersion
, runStackVer :: Maybe ToolVersion
, runBinDir :: Maybe FilePath
, runQuick :: Bool
2022-02-09 17:57:59 +00:00
, runCOMMAND :: [String]
}
---------------
--[ Parsers ]--
---------------
2022-02-09 17:57:59 +00:00
runOpts :: Parser RunOptions
runOpts =
RunOptions
<$> switch
(short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)")
<*> switch
(short 'i' <> long "install" <> help "Install the tool, if missing")
2022-06-06 21:02:21 +00:00
<*> switch
(short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)")
2022-02-09 17:57:59 +00:00
<*> optional
(option
(eitherReader ghcVersionTagEither)
2022-03-04 23:46:37 +00:00
(metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"
<> completer (tagCompleter GHC [])
<> (completer $ versionCompleter Nothing GHC)
)
2022-02-09 17:57:59 +00:00
)
<*> optional
(option
(eitherReader toolVersionTagEither)
2022-03-04 23:46:37 +00:00
(metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"
<> completer (tagCompleter Cabal [])
<> (completer $ versionCompleter Nothing Cabal)
)
2022-02-09 17:57:59 +00:00
)
<*> optional
(option
(eitherReader toolVersionTagEither)
2022-03-04 23:46:37 +00:00
(metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"
<> completer (tagCompleter HLS [])
<> (completer $ versionCompleter Nothing HLS)
)
2022-02-09 17:57:59 +00:00
)
<*> optional
(option
(eitherReader toolVersionTagEither)
2022-03-04 23:46:37 +00:00
(metavar "STACK_VERSION" <> long "stack" <> help "The stack version"
<> completer (tagCompleter Stack [])
<> (completer $ versionCompleter Nothing Stack)
)
2022-02-09 17:57:59 +00:00
)
<*> optional
(option
(eitherReader isolateParser)
( short 'b'
<> long "bindir"
<> metavar "DIR"
<> help "directory where to create the tool symlinks (default: newly created system temp dir)"
2022-03-04 23:46:37 +00:00
<> completer (bashCompleter "directory")
2022-02-09 17:57:59 +00:00
)
)
<*> switch
(short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.")
2022-02-09 17:57:59 +00:00
<*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))
--------------
--[ Footer ]--
--------------
runFooter :: String
runFooter = [s|Discussion:
Adds the given tools to a dedicated bin/ directory and adds them to PATH, exposing
the relevant binaries, then executes a command.
Examples:
# run VSCode with all latest toolchain exposed, installing missing versions if necessary
ghcup run --ghc latest --cabal latest --hls latest --stack latest --install -- code Setup.hs
# create a custom toolchain bin/ dir with GHC and cabal that can be manually added to PATH
ghcup run --ghc 8.10.7 --cabal 3.2.0.0 --bindir $HOME/toolchain/bin
# run a specific ghc version
ghcup run --ghc 8.10.7 -- ghc --version|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type RunEffects = '[ AlreadyInstalled
, UnknownArchive
, ArchiveResult
, FileDoesNotExistError
, CopyError
, NotInstalled
, DirNotEmpty
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, ContentLengthError
2022-02-09 17:57:59 +00:00
, GPGError
, DownloadFailed
, TarDirDoesNotExist
, NextVerNotFound
, NoToolVersionSet
, FileAlreadyExistsError
, ProcessError
, UninstallFailed
, MergeFileTreeError
2022-02-09 17:57:59 +00:00
]
2022-02-10 18:29:32 +00:00
runLeanRUN :: (MonadUnliftIO m, MonadIO m)
=> LeanAppState
-> Excepts RunEffects (ReaderT LeanAppState m) a
-> m (VEither RunEffects a)
runLeanRUN leanAppstate =
-- Don't use runLeanAppState here, which is disabled on windows.
-- This is the only command on all platforms that doesn't need full appstate.
flip runReaderT leanAppstate
. runE
@RunEffects
2022-02-09 17:57:59 +00:00
runRUN :: MonadUnliftIO m
2022-03-17 23:42:48 +00:00
=> IO AppState
2022-02-09 17:57:59 +00:00
-> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither RunEffects a)
2022-03-17 23:42:48 +00:00
runRUN appState action' = do
s' <- liftIO appState
flip runReaderT s'
2022-02-09 17:57:59 +00:00
. runResourceT
. runE
@RunEffects
2022-03-17 23:42:48 +00:00
$ action'
2022-02-09 17:57:59 +00:00
------------------
--[ Entrypoint ]--
------------------
run :: forall m .
2022-02-09 17:57:59 +00:00
( MonadFail m
, MonadMask m
, MonadCatch m
, MonadIO m
, MonadUnliftIO m
)
=> RunOptions
2022-03-17 23:42:48 +00:00
-> IO AppState
2022-02-10 18:29:32 +00:00
-> LeanAppState
2022-02-09 17:57:59 +00:00
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
2022-03-17 23:42:48 +00:00
run RunOptions{..} runAppState leanAppstate runLogger = do
r <- if not runQuick
2022-03-17 23:42:48 +00:00
then runRUN runAppState $ do
toolchain <- liftE resolveToolchainFull
-- oh dear
r <- lift ask
tmp <- lift . lift . lift . flip runReaderT (fromAppState r) $ createTmpDir toolchain
2022-03-17 23:42:48 +00:00
liftE $ installToolChainFull toolchain tmp
pure tmp
else runLeanRUN leanAppstate $ do
toolchain <- resolveToolchain
tmp <- lift $ createTmpDir toolchain
2022-03-17 23:42:48 +00:00
liftE $ installToolChain toolchain tmp
pure tmp
case r of
VRight tmp -> do
case runCOMMAND of
[] -> do
liftIO $ putStr tmp
pure ExitSuccess
(cmd:args) -> do
newEnv <- liftIO $ addToPath tmp runAppendPATH
2022-02-10 17:35:25 +00:00
#ifndef IS_WINDOWS
2022-03-17 23:42:48 +00:00
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
pure ExitSuccess
2022-02-10 17:35:25 +00:00
#else
2022-06-06 21:02:21 +00:00
r' <- if runMinGWPath
then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv)
2022-03-17 23:42:48 +00:00
case r' of
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyHFError e
2022-03-17 23:42:48 +00:00
pure $ ExitFailure 28
2022-02-10 17:35:25 +00:00
#endif
2022-03-17 23:42:48 +00:00
VLeft e -> do
runLogger $ logError $ T.pack $ prettyHFError e
2022-03-17 23:42:48 +00:00
pure $ ExitFailure 27
2022-02-09 17:57:59 +00:00
where
2022-03-17 23:42:48 +00:00
2022-02-09 17:57:59 +00:00
-- TODO: doesn't work for cross
2022-03-17 23:42:48 +00:00
resolveToolchainFull :: ( MonadFail m
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
] (ResourceT (ReaderT AppState m)) Toolchain
resolveToolchainFull = do
ghcVer <- forM runGHCVer $ \ver -> do
2022-02-10 18:29:32 +00:00
(v, _) <- liftE $ fromVersion (Just ver) GHC
pure v
cabalVer <- forM runCabalVer $ \ver -> do
2022-02-10 18:29:32 +00:00
(v, _) <- liftE $ fromVersion (Just ver) Cabal
pure (_tvVersion v)
hlsVer <- forM runHLSVer $ \ver -> do
2022-02-10 18:29:32 +00:00
(v, _) <- liftE $ fromVersion (Just ver) HLS
pure (_tvVersion v)
stackVer <- forM runStackVer $ \ver -> do
2022-02-10 18:29:32 +00:00
(v, _) <- liftE $ fromVersion (Just ver) Stack
pure (_tvVersion v)
pure Toolchain{..}
2022-03-17 23:42:48 +00:00
resolveToolchain = do
ghcVer <- case runGHCVer of
Just (GHCVersion v) -> pure $ Just v
Just (ToolVersion v) -> pure $ Just (mkTVer v)
Nothing -> pure Nothing
2022-02-10 18:29:32 +00:00
_ -> fail "Internal error"
cabalVer <- case runCabalVer of
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
Just (ToolVersion v) -> pure $ Just v
Nothing -> pure Nothing
2022-02-10 18:29:32 +00:00
_ -> fail "Internal error"
hlsVer <- case runHLSVer of
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
Just (ToolVersion v) -> pure $ Just v
Nothing -> pure Nothing
2022-02-10 18:29:32 +00:00
_ -> fail "Internal error"
stackVer <- case runStackVer of
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
Just (ToolVersion v) -> pure $ Just v
Nothing -> pure Nothing
2022-02-10 18:29:32 +00:00
_ -> fail "Internal error"
pure Toolchain{..}
2022-02-10 18:29:32 +00:00
2022-03-17 23:42:48 +00:00
installToolChainFull :: ( MonadFail m
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Toolchain
-> FilePath
-> Excepts
'[ TagNotFound
, NextVerNotFound
, NoToolVersionSet
, UnknownArchive
, TarDirDoesNotExist
, ProcessError
, NotInstalled
, NoDownload
, GPGError
, DownloadFailed
, DirNotEmpty
, DigestError
, ContentLengthError
2022-03-17 23:42:48 +00:00
, BuildFailed
, ArchiveResult
, AlreadyInstalled
, FileAlreadyExistsError
, CopyError
, UninstallFailed
, MergeFileTreeError
2022-03-17 23:42:48 +00:00
] (ResourceT (ReaderT AppState m)) ()
installToolChainFull Toolchain{..} tmp = do
case ghcVer of
Just v -> do
isInstalled <- lift $ checkIfToolInstalled' GHC v
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
(_tvVersion v)
GHCupInternal
False
[]
setGHC' v tmp
_ -> pure ()
case cabalVer of
Just v -> do
isInstalled <- lift $ checkIfToolInstalled' Cabal (mkTVer v)
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
v
GHCupInternal
False
setCabal' v tmp
_ -> pure ()
case stackVer of
Just v -> do
isInstalled <- lift $ checkIfToolInstalled' Stack (mkTVer v)
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
v
GHCupInternal
False
setStack' v tmp
_ -> pure ()
case hlsVer of
Just v -> do
isInstalled <- lift $ checkIfToolInstalled' HLS (mkTVer v)
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
v
GHCupInternal
False
setHLS' v tmp
_ -> pure ()
2022-03-17 23:42:48 +00:00
installToolChain :: ( MonadFail m
, MonadThrow m
, MonadIO m
, MonadCatch m
)
=> Toolchain
-> FilePath
-> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()
installToolChain Toolchain{..} tmp = do
case ghcVer of
Just v -> setGHC' v tmp
_ -> pure ()
case cabalVer of
Just v -> setCabal' v tmp
_ -> pure ()
case stackVer of
Just v -> setStack' v tmp
_ -> pure ()
case hlsVer of
Just v -> setHLS' v tmp
_ -> pure ()
setGHC' v tmp = do
2022-02-10 18:29:32 +00:00
void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)
void $ liftE $ setGHC v SetGHCOnly (Just tmp)
setCabal' v tmp = do
bin <- liftE $ whereIsTool Cabal (mkTVer v)
2022-02-10 18:29:32 +00:00
cbin <- liftIO $ canonicalizePath bin
2022-02-10 20:49:19 +00:00
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))
setStack' v tmp = do
bin <- liftE $ whereIsTool Stack (mkTVer v)
2022-02-10 18:29:32 +00:00
cbin <- liftIO $ canonicalizePath bin
2022-02-10 20:49:19 +00:00
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))
setHLS' v tmp = do
2022-02-10 19:35:09 +00:00
Dirs {..} <- getDirs
legacy <- isLegacyHLS v
2022-02-10 19:35:09 +00:00
if legacy
then do
-- TODO: factor this out
hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? (NotInstalled HLS (mkTVer v))
2022-02-10 19:35:09 +00:00
cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)
lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)
hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))
2022-02-10 19:35:09 +00:00
forM_ hlsBins $ \bin ->
lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin)
liftE $ setHLS v SetHLSOnly (Just tmp)
2022-02-10 19:35:09 +00:00
else do
liftE $ setHLS v SetHLS_XYZ (Just tmp)
liftE $ setHLS v SetHLSOnly (Just tmp)
createTmpDir :: ( MonadUnliftIO m
, MonadCatch m
, MonadThrow m
, MonadMask m
, MonadIO m
)
=> Toolchain
-> ReaderT LeanAppState m FilePath
createTmpDir toolchain =
case runBinDir of
Just bindir -> do
liftIO $ createDirRecursive' bindir
liftIO $ canonicalizePath bindir
Nothing -> do
d <- predictableTmpDir toolchain
liftIO $ createDirRecursive' d
liftIO $ canonicalizePath d
predictableTmpDir :: Monad m
=> Toolchain
-> ReaderT LeanAppState m FilePath
predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) = do
Dirs { tmpDir } <- getDirs
pure (fromGHCupPath tmpDir </> "ghcup-none")
predictableTmpDir Toolchain{..} = do
Dirs { tmpDir } <- getDirs
pure $ fromGHCupPath tmpDir
</> ("ghcup-" <> intercalate "_"
( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer
<> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . prettyVer) cabalVer
<> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . prettyVer) hlsVer
<> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . prettyVer) stackVer
)
)
-------------------------
--[ Other local types ]--
-------------------------
data Toolchain = Toolchain
{ ghcVer :: Maybe GHCTargetVersion
, cabalVer :: Maybe Version
, hlsVer :: Maybe Version
, stackVer :: Maybe Version
} deriving Show