{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module GHCup.OptParse.Run where import GHCup import GHCup.Utils import GHCup.OptParse.Common import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Prelude import GHCup.Prelude.File #ifdef IS_WINDOWS import GHCup.Prelude.Process import GHCup.Prelude.Process.Windows ( execNoMinGW ) #endif import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ 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 Text.PrettyPrint.HughesPJClass ( prettyShow ) 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 ) --------------- --[ Options ]-- --------------- data RunOptions = RunOptions { runAppendPATH :: Bool , runInstTool' :: Bool , runMinGWPath :: Bool , runGHCVer :: Maybe ToolVersion , runCabalVer :: Maybe ToolVersion , runHLSVer :: Maybe ToolVersion , runStackVer :: Maybe ToolVersion , runBinDir :: Maybe FilePath , runQuick :: Bool , runCOMMAND :: [String] } --------------- --[ Parsers ]-- --------------- 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") <*> switch (short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)") <*> optional (option (eitherReader ghcVersionTagEither) (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version" <> completer (tagCompleter GHC []) <> (completer $ versionCompleter Nothing GHC) ) ) <*> optional (option (eitherReader toolVersionTagEither) (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version" <> completer (tagCompleter Cabal []) <> (completer $ versionCompleter Nothing Cabal) ) ) <*> optional (option (eitherReader toolVersionTagEither) (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version" <> completer (tagCompleter HLS []) <> (completer $ versionCompleter Nothing HLS) ) ) <*> optional (option (eitherReader toolVersionTagEither) (metavar "STACK_VERSION" <> long "stack" <> help "The stack version" <> completer (tagCompleter Stack []) <> (completer $ versionCompleter Nothing Stack) ) ) <*> optional (option (eitherReader isolateParser) ( short 'b' <> long "bindir" <> metavar "DIR" <> help "directory where to create the tool symlinks (default: newly created system temp dir)" <> completer (bashCompleter "directory") ) ) <*> switch (short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.") <*> 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 , GPGError , DownloadFailed , TarDirDoesNotExist , NextVerNotFound , NoToolVersionSet , FileAlreadyExistsError , ProcessError , UninstallFailed , MergeFileTreeError ] 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 runRUN :: MonadUnliftIO m => IO AppState -> Excepts RunEffects (ResourceT (ReaderT AppState m)) a -> m (VEither RunEffects a) runRUN appState action' = do s' <- liftIO appState flip runReaderT s' . runResourceT . runE @RunEffects $ action' ------------------ --[ Entrypoint ]-- ------------------ run :: forall m . ( MonadFail m , MonadMask m , MonadCatch m , MonadIO m , MonadUnliftIO m ) => RunOptions -> IO AppState -> LeanAppState -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode run RunOptions{..} runAppState leanAppstate runLogger = do r <- if not runQuick then runRUN runAppState $ do toolchain <- liftE resolveToolchainFull -- oh dear r <- lift ask tmp <- lift . lift . lift . flip runReaderT (fromAppState r) $ createTmpDir toolchain liftE $ installToolChainFull toolchain tmp pure tmp else runLeanRUN leanAppstate $ do toolchain <- resolveToolchain tmp <- lift $ createTmpDir toolchain 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 #ifndef IS_WINDOWS void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) pure ExitSuccess #else 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) case r' of VRight _ -> pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e pure $ ExitFailure 28 #endif VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e pure $ ExitFailure 27 where -- TODO: doesn't work for cross 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 (v, _) <- liftE $ fromVersion (Just ver) GHC pure v cabalVer <- forM runCabalVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) Cabal pure (_tvVersion v) hlsVer <- forM runHLSVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) HLS pure (_tvVersion v) stackVer <- forM runStackVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) Stack pure (_tvVersion v) pure Toolchain{..} resolveToolchain = do ghcVer <- case runGHCVer of Just (GHCVersion v) -> pure $ Just v Just (ToolVersion v) -> pure $ Just (mkTVer v) Nothing -> pure Nothing _ -> fail "Internal error" cabalVer <- case runCabalVer of Just (GHCVersion v) -> pure $ Just (_tvVersion v) Just (ToolVersion v) -> pure $ Just v Nothing -> pure Nothing _ -> fail "Internal error" hlsVer <- case runHLSVer of Just (GHCVersion v) -> pure $ Just (_tvVersion v) Just (ToolVersion v) -> pure $ Just v Nothing -> pure Nothing _ -> fail "Internal error" stackVer <- case runStackVer of Just (GHCVersion v) -> pure $ Just (_tvVersion v) Just (ToolVersion v) -> pure $ Just v Nothing -> pure Nothing _ -> fail "Internal error" pure Toolchain{..} 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 , BuildFailed , ArchiveResult , AlreadyInstalled , FileAlreadyExistsError , CopyError , UninstallFailed , MergeFileTreeError ] (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 () 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 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) cbin <- liftIO $ canonicalizePath bin lift $ createLink (relativeSymlink tmp cbin) (tmp ("cabal" <.> exeExt)) setStack' v tmp = do bin <- liftE $ whereIsTool Stack (mkTVer v) cbin <- liftIO $ canonicalizePath bin lift $ createLink (relativeSymlink tmp cbin) (tmp ("stack" <.> exeExt)) setHLS' v tmp = do Dirs {..} <- getDirs legacy <- isLegacyHLS v if legacy then do -- TODO: factor this out hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? (NotInstalled HLS (mkTVer v)) cw <- liftIO $ canonicalizePath (binDir hlsWrapper) lift $ createLink (relativeSymlink tmp cw) (tmp takeFileName cw) hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir )) forM_ hlsBins $ \bin -> lift $ createLink (relativeSymlink tmp bin) (tmp takeFileName bin) liftE $ setHLS v SetHLSOnly (Just tmp) else do liftE $ setHLS v SetHLS_XYZ (Just tmp) liftE $ setHLS v SetHLSOnly (Just tmp) addToPath path = do cEnv <- Map.fromList <$> getEnvironment let paths = ["PATH", "Path"] curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths newPath = intercalate [searchPathSeparator] (if runAppendPATH then (curPaths ++ [path]) else (path : curPaths)) envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths pathVar = if isWindows then "Path" else "PATH" envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath liftIO $ setEnv pathVar newPath return envWithNewPath 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