{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-| Module : GHCup.Utils Description : GHCup domain specific utilities Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable This module contains GHCup helpers specific to installation and introspection of files/versions etc. -} module GHCup.Utils ( module GHCup.Utils.Dirs , module GHCup.Utils #if defined(IS_WINDOWS) , module GHCup.Utils.Windows #else , module GHCup.Utils.Posix #endif ) where #if defined(IS_WINDOWS) import GHCup.Utils.Windows #else import GHCup.Utils.Posix #endif import GHCup.Download import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs import GHCup.Utils.File import GHCup.Utils.Logger import GHCup.Utils.MegaParsec import GHCup.Utils.Prelude import GHCup.Utils.String.QQ import Codec.Archive hiding ( Directory ) import Control.Applicative import Control.Exception.Safe import Control.Monad #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif import Control.Monad.Reader import Control.Monad.Trans.Resource hiding ( throwM ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Data.Bifunctor ( first ) import Data.ByteString ( ByteString ) import Data.Either import Data.Foldable import Data.List import Data.List.NonEmpty ( NonEmpty( (:|) )) import Data.Maybe import Data.Text ( Text ) import Data.Versions hiding ( patch ) import GHC.IO.Exception import Haskus.Utils.Variant.Excepts import Optics import Safe import System.Directory hiding ( findFiles ) import System.FilePath import System.IO.Error import Text.Regex.Posix import URI.ByteString import qualified Codec.Compression.BZip as BZip import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.Lzma as Lzma import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP import qualified Data.List.NonEmpty as NE -- $setup -- >>> :set -XOverloadedStrings -- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> :set -XQuasiQuotes -- >>> import System.Directory -- >>> import URI.ByteString -- >>> import qualified Data.Text as T -- >>> import GHCup.Utils.Prelude -- >>> import GHCup.Download -- >>> import GHCup.Version -- >>> import GHCup.Errors -- >>> import GHCup.Types -- >>> import GHCup.Types.Optics -- >>> import Optics -- >>> import GHCup.Utils.Version.QQ -- >>> import qualified Data.Text.Encoding as E -- >>> import Control.Monad.Reader -- >>> import Haskus.Utils.Variant.Excepts -- >>> import Text.PrettyPrint.HughesPJClass ( prettyShow ) -- >>> let lc = LoggerConfig { lcPrintDebug = False, consoleOutter = mempty, fileOutter = mempty, fancyColors = False } -- >>> dirs' <- getAllDirs -- >>> let installedVersions = [ ([pver|8.10.7|], "-debug+lol", Nothing), ([pver|8.10.4|], "", Nothing), ([pver|8.8.4|], "", Nothing), ([pver|8.8.3|], "", Nothing) ] -- >>> let settings = Settings True 0 False Never Curl False GHCupURL True GPGNone False -- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc -- >>> cwd <- getCurrentDirectory -- >>> (Right ref) <- pure $ parseURI strictURIParserOptions $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL) -- >>> (VRight r) <- (fmap . fmap) _ghcupDownloads $ flip runReaderT leanAppState . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] $ liftE $ getBase ref ------------------------ --[ Symlink handling ]-- ------------------------ -- | Create a relative symlink destination for the binary directory, -- given a target toolpath. binarySymLinkDestination :: ( MonadThrow m , MonadIO m ) => FilePath -- ^ binary dir -> FilePath -- ^ the full toolpath -> m FilePath binarySymLinkDestination binDir toolPath = do toolPath' <- liftIO $ canonicalizePath toolPath binDir' <- liftIO $ canonicalizePath binDir pure (relativeSymlink binDir' toolPath') -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5. rmMinorGHCSymlinks :: ( MonadReader env m , HasDirs env , MonadIO m , HasLog env , MonadThrow m , MonadFail m , MonadMask m ) => GHCTargetVersion -> Excepts '[NotInstalled] m () rmMinorGHCSymlinks tv@GHCTargetVersion{..} = do Dirs {..} <- lift getDirs files <- liftE $ ghcToolFiles tv forM_ files $ \f -> do let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt let fullF = binDir f_xyz lift $ logDebug ("rm -f " <> T.pack fullF) lift $ hideError doesNotExistErrorType $ rmLink fullF -- | Removes the set ghc version for the given target, if any. rmPlainGHC :: ( MonadReader env m , HasDirs env , HasLog env , MonadThrow m , MonadFail m , MonadIO m , MonadMask m ) => Maybe Text -- ^ target -> Excepts '[NotInstalled] m () rmPlainGHC target = do Dirs {..} <- lift getDirs mtv <- lift $ ghcSet target forM_ mtv $ \tv -> do files <- liftE $ ghcToolFiles tv forM_ files $ \f -> do let fullF = binDir f <> exeExt lift $ logDebug ("rm -f " <> T.pack fullF) lift $ hideError doesNotExistErrorType $ rmLink fullF -- old ghcup let hdc_file = binDir "haddock-ghc" <> exeExt lift $ logDebug ("rm -f " <> T.pack hdc_file) lift $ hideError doesNotExistErrorType $ rmLink hdc_file -- | Remove the major GHC symlink, e.g. ghc-8.6. rmMajorGHCSymlinks :: ( MonadReader env m , HasDirs env , MonadIO m , HasLog env , MonadThrow m , MonadFail m , MonadMask m ) => GHCTargetVersion -> Excepts '[NotInstalled] m () rmMajorGHCSymlinks tv@GHCTargetVersion{..} = do Dirs {..} <- lift getDirs (mj, mi) <- getMajorMinorV _tvVersion let v' = intToText mj <> "." <> intToText mi files <- liftE $ ghcToolFiles tv forM_ files $ \f -> do let f_xy = f <> "-" <> T.unpack v' <> exeExt let fullF = binDir f_xy lift $ logDebug ("rm -f " <> T.pack fullF) lift $ hideError doesNotExistErrorType $ rmLink fullF -- | Removes the minor HLS files, e.g. 'haskell-language-server-8.10.7~1.6.1.0' -- and 'haskell-language-server-wrapper-1.6.1.0'. rmMinorHLSSymlinks :: ( MonadReader env m , HasDirs env , MonadIO m , HasLog env , MonadThrow m , MonadFail m , MonadMask m ) => Version -> Excepts '[NotInstalled] m () rmMinorHLSSymlinks ver = do Dirs {..} <- lift getDirs hlsBins <- hlsAllBinaries ver forM_ hlsBins $ \f -> do let fullF = binDir f lift $ logDebug ("rm -f " <> T.pack fullF) -- on unix, this may be either a file (legacy) or a symlink -- on windows, this is always a file... hence 'rmFile' -- works consistently across platforms lift $ rmFile fullF -- | Removes the set HLS version, if any. rmPlainHLS :: ( MonadReader env m , HasDirs env , HasLog env , MonadThrow m , MonadFail m , MonadIO m , MonadMask m ) => Excepts '[NotInstalled] m () rmPlainHLS = do Dirs {..} <- lift getDirs -- delete 'haskell-language-server-8.10.7' hlsBins <- fmap (filter (\f -> not ("haskell-language-server-wrapper" `isPrefixOf` f) && ('~' `notElem` f))) $ liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)) forM_ hlsBins $ \f -> do let fullF = binDir f lift $ logDebug ("rm -f " <> T.pack fullF) if isWindows then lift $ rmLink fullF else lift $ rmFile fullF -- 'haskell-language-server-wrapper' let hlswrapper = binDir "haskell-language-server-wrapper" <> exeExt lift $ logDebug ("rm -f " <> T.pack hlswrapper) if isWindows then lift $ hideError doesNotExistErrorType $ rmLink hlswrapper else lift $ hideError doesNotExistErrorType $ rmFile hlswrapper ----------------------------------- --[ Set/Installed introspection ]-- ----------------------------------- -- | Whether the given GHC versin is installed. ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver liftIO $ doesDirectoryExist ghcdir -- | Whether the given GHC version is installed from source. ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcSrcInstalled ver = do ghcdir <- ghcupGHCDir ver liftIO $ doesFileExist (ghcdir ghcUpSrcBuiltFile) -- | Whether the given GHC version is set as the current. ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) => Maybe Text -- ^ the target of the GHC version, if any -- (e.g. armv7-unknown-linux-gnueabihf) -> m (Maybe GHCTargetVersion) ghcSet mtarget = do Dirs {..} <- getDirs let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget let ghcBin = binDir ghc <> exeExt -- link destination is of the form ../ghc//bin/ghc -- for old ghcup, it is ../ghc//bin/ghc- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do link <- liftIO $ getLinkTarget ghcBin Just <$> ghcLinkVersion link where ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t where parser = (do _ <- parseUntil1 ghcSubPath _ <- ghcSubPath r <- parseUntil1 pathSep rest <- MP.getInput MP.setInput r x <- ghcTargetVerP MP.setInput rest pure x ) <* MP.some pathSep <* MP.takeRest <* MP.eof ghcSubPath = MP.some pathSep <* MP.chunk "ghc" *> MP.some pathSep -- | Get all installed GHCs by reading ~/.ghcup/ghc/. -- If a dir cannot be parsed, returns left. getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion] getInstalledGHCs = do ghcdir <- ghcupGHCBaseDir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir forM fs $ \f -> case parseGHCupGHCDir f of Right r -> pure $ Right r Left _ -> pure $ Left f -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. getInstalledCabals :: ( MonadReader env m , HasDirs env , MonadIO m , MonadCatch m ) => m [Either FilePath Version] getInstalledCabals = do Dirs {..} <- getDirs bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString)) vs <- forM bins $ \f -> case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "cabal-" f) of Just (Right r) -> pure $ Right r Just (Left _) -> pure $ Left f Nothing -> pure $ Left f pure $ nub vs -- | Whether the given cabal version is installed. cabalInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool cabalInstalled ver = do vers <- fmap rights getInstalledCabals pure $ elem ver vers -- Return the currently set cabal version, if any. cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) cabalSet = do Dirs {..} <- getDirs let cabalbin = binDir "cabal" <> exeExt handleIO' NoSuchThing (\_ -> pure Nothing) $ do broken <- liftIO $ isBrokenSymlink cabalbin if broken then pure Nothing else do link <- liftIO $ handleIO' InvalidArgument (\e -> pure $ Left (toException e)) $ fmap Right $ getLinkTarget cabalbin case linkVersion =<< link of Right v -> pure $ Just v Left err -> do logWarn $ "Failed to parse cabal symlink target with: " <> T.pack (displayException err) <> ". The symlink " <> T.pack cabalbin <> " needs to point to valid cabal binary, such as 'cabal-3.4.0.0'." pure Nothing where -- We try to be extra permissive with link destination parsing, -- because of: -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119 linkVersion :: MonadThrow m => FilePath -> m Version linkVersion = throwEither . MP.parse parser "linkVersion" . T.pack . dropSuffix exeExt parser = MP.try (stripAbsolutePath *> cabalParse) <|> MP.try (stripRelativePath *> cabalParse) <|> cabalParse -- parses the version of "cabal-3.2.0.0" -> "3.2.0.0" cabalParse = MP.chunk "cabal-" *> version' -- parses any path component ending with path separator, -- e.g. "foo/" stripPathComponet = parseUntil1 pathSep *> MP.some pathSep -- parses an absolute path up until the last path separator, -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo" stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) -- parses a relative path up until the last path separator, -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" stripRelativePath = MP.many (MP.try stripPathComponet) -- | Get all installed hls, by matching on -- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@, -- as well as @~\/.ghcup\/hls\/<\hlsver\>@ getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [Either FilePath Version] getInstalledHLSs = do Dirs {..} <- getDirs bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^haskell-language-server-wrapper-.*$|] :: ByteString) ) legacy <- forM bins $ \f -> case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f) of Just (Right r) -> pure $ Right r Just (Left _) -> pure $ Left f Nothing -> pure $ Left f hlsdir <- ghcupHLSBaseDir fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir new <- forM fs $ \f -> case parseGHCupHLSDir f of Right r -> pure $ Right r Left _ -> pure $ Left f pure (nub (new <> legacy)) -- | Get all installed stacks, by matching on -- @~\/.ghcup\/bin/stack-<\stackver\>@. getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [Either FilePath Version] getInstalledStacks = do Dirs {..} <- getDirs bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^stack-.*$|] :: ByteString) ) forM bins $ \f -> case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "stack-" f) of Just (Right r) -> pure $ Right r Just (Left _) -> pure $ Left f Nothing -> pure $ Left f -- Return the currently set stack version, if any. -- TODO: there's a lot of code duplication here :> stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, HasLog env) => m (Maybe Version) stackSet = do Dirs {..} <- getDirs let stackBin = binDir "stack" <> exeExt handleIO' NoSuchThing (\_ -> pure Nothing) $ do broken <- liftIO $ isBrokenSymlink stackBin if broken then pure Nothing else do link <- liftIO $ handleIO' InvalidArgument (\e -> pure $ Left (toException e)) $ fmap Right $ getLinkTarget stackBin case linkVersion =<< link of Right v -> pure $ Just v Left err -> do logWarn $ "Failed to parse stack symlink target with: " <> T.pack (displayException err) <> ". The symlink " <> T.pack stackBin <> " needs to point to valid stack binary, such as 'stack-2.7.1'." pure Nothing where linkVersion :: MonadThrow m => FilePath -> m Version linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt where parser = MP.try (stripAbsolutePath *> cabalParse) <|> MP.try (stripRelativePath *> cabalParse) <|> cabalParse -- parses the version of "stack-2.7.1" -> "2.7.1" cabalParse = MP.chunk "stack-" *> version' -- parses any path component ending with path separator, -- e.g. "foo/" stripPathComponet = parseUntil1 pathSep *> MP.some pathSep -- parses an absolute path up until the last path separator, -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo" stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) -- parses a relative path up until the last path separator, -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" stripRelativePath = MP.many (MP.try stripPathComponet) -- | Whether the given Stack version is installed. stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool stackInstalled ver = do vers <- fmap rights getInstalledStacks pure $ elem ver vers -- | Whether the given HLS version is installed. hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool hlsInstalled ver = do vers <- fmap rights getInstalledHLSs pure $ elem ver vers isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool isLegacyHLS ver = do bdir <- ghcupHLSDir ver not <$> liftIO (doesDirectoryExist bdir) -- Return the currently set hls version, if any. hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) hlsSet = do Dirs {..} <- getDirs let hlsBin = binDir "haskell-language-server-wrapper" <> exeExt liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do broken <- isBrokenSymlink hlsBin if broken then pure Nothing else do link <- liftIO $ getLinkTarget hlsBin Just <$> linkVersion link where linkVersion :: MonadThrow m => FilePath -> m Version linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt where parser = MP.try (stripAbsolutePath *> cabalParse) <|> MP.try (stripRelativePath *> cabalParse) <|> cabalParse -- parses the version of "haskell-language-server-wrapper-1.1.0" -> "1.1.0" cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version' -- parses any path component ending with path separator, -- e.g. "foo/" stripPathComponet = parseUntil1 pathSep *> MP.some pathSep -- parses an absolute path up until the last path separator, -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo" stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) -- parses a relative path up until the last path separator, -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" stripRelativePath = MP.many (MP.try stripPathComponet) -- | Return the GHC versions the currently selected HLS supports. hlsGHCVersions :: ( MonadReader env m , HasDirs env , MonadIO m , MonadThrow m , MonadCatch m ) => m [Version] hlsGHCVersions = do h <- hlsSet fromMaybe [] <$> forM h hlsGHCVersions' hlsGHCVersions' :: ( MonadReader env m , HasDirs env , MonadIO m , MonadThrow m , MonadCatch m ) => Version -> m [Version] hlsGHCVersions' v' = do bins <- hlsServerBinaries v' Nothing let vers = fmap (version . T.pack . fromJust . stripPrefix "haskell-language-server-" . head . splitOn "~" ) bins pure . sortBy (flip compare) . rights $ vers -- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, if any. hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m) => Version -> Maybe Version -- ^ optional GHC version -> m [FilePath] hlsServerBinaries ver mghcVer = do Dirs {..} <- getDirs liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^haskell-language-server-|] <> maybe [s|.*|] escapeVerRex mghcVer <> [s|~|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString ) ) -- | Get all scripts for a hls version from the ~/.ghcup/hls//bin directory, if any. -- Returns the full path. hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> Maybe Version -- ^ optional GHC version -> m [FilePath] hlsInternalServerScripts ver mghcVer = do dir <- ghcupHLSDir ver let bdir = dir "bin" fmap (bdir ) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer) <$> liftIO (listDirectory bdir) -- | Get all binaries for a hls version from the ~/.ghcup/hls//lib/haskell-language-server-/bin directory, if any. -- Returns the full path. hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m) => Version -> Maybe Version -- ^ optional GHC version -> m [FilePath] hlsInternalServerBinaries ver mghcVer = do dir <- ghcupHLSDir ver let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString) (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir "lib"), Right regex, Left "bin"] fmap (bdir ) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer) <$> liftIO (listDirectory bdir) -- | Get all libraries for a hls version from the ~/.ghcup/hls//lib/haskell-language-server-/lib// -- directory, if any. -- Returns the full path. hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m) => Version -> Version -- ^ GHC version -> m [FilePath] hlsInternalServerLibs ver ghcVer = do dir <- ghcupHLSDir ver let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString) (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir "lib"), Right regex, Left ("lib" T.unpack (prettyVer ghcVer))] fmap (bdir ) <$> liftIO (listDirectory bdir) -- | Get the wrapper binary for an hls version, if any. hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) => Version -> m (Maybe FilePath) hlsWrapperBinary ver = do Dirs {..} <- getDirs wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles binDir (makeRegexOpts compExtended execBlank ([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString ) ) case wrapper of [] -> pure Nothing [x] -> pure $ Just x _ -> throwM $ UnexpectedListLength "There were multiple hls wrapper binaries for a single version" -- | Get all binaries for an hls version, if any. hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath] hlsAllBinaries ver = do hls <- hlsServerBinaries ver Nothing wrapper <- hlsWrapperBinary ver pure (maybeToList wrapper ++ hls) ----------------------------------------- --[ Major version introspection (X.Y) ]-- ----------------------------------------- -- | Extract (major, minor) from any version. getMajorMinorV :: MonadThrow m => Version -> m (Int, Int) getMajorMinorV Version {..} = case _vChunks of ((Digits x :| []) :| ((Digits y :| []):_)) -> pure (fromIntegral x, fromIntegral y) _ -> throwM $ ParseError "Could not parse X.Y from version" matchMajor :: Version -> Int -> Int -> Bool matchMajor v' major' minor' = case getMajorMinorV v' of Just (x, y) -> x == major' && y == minor' Nothing -> False -- | Match PVP prefix. -- -- >>> matchPVPrefix [pver|8.8|] [pver|8.8.4|] -- True -- >>> matchPVPrefix [pver|8|] [pver|8.8.4|] -- True -- >>> matchPVPrefix [pver|8.10|] [pver|8.8.4|] -- False -- >>> matchPVPrefix [pver|8.10|] [pver|8.10.7|] -- True matchPVPrefix :: PVP -> PVP -> Bool matchPVPrefix (toL -> prefix) (toL -> full) = and $ zipWith (==) prefix full toL :: PVP -> [Int] toL (PVP inner) = fmap fromIntegral $ NE.toList inner -- | Get the latest installed full GHC version that satisfies the given (possibly partial) -- PVP version. getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => PVP -> Maybe Text -- ^ the target triple -> m (Maybe GHCTargetVersion) getGHCForPVP pvpIn mt = do ghcs <- rights <$> getInstalledGHCs -- we're permissive here... failed parse just means we have no match anyway let ghcs' = catMaybes $ flip fmap ghcs $ \GHCTargetVersion{..} -> do (pvp_, rest) <- versionToPVP _tvVersion pure (pvp_, rest, _tvTarget) getGHCForPVP' pvpIn ghcs' mt -- | Like 'getGHCForPVP', except with explicit input parameter. -- -- >>> getGHCForPVP' [pver|8|] installedVersions Nothing -- Just (GHCTargetVersion {_tvTarget = Nothing, _tvVersion = Version {_vEpoch = Nothing, _vChunks = (Digits 8 :| []) :| [Digits 10 :| [],Digits 7 :| []], _vRel = [Str "debug" :| []], _vMeta = Just "lol"}}) -- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing -- "Just 8.8.4" -- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing -- "Just 8.10.4" getGHCForPVP' :: MonadThrow m => PVP -> [(PVP, Text, Maybe Text)] -- ^ installed GHCs -> Maybe Text -- ^ the target triple -> m (Maybe GHCTargetVersion) getGHCForPVP' pvpIn ghcs' mt = do let mResult = lastMay . sortBy (\(x, _, _) (y, _, _) -> compare x y) . filter (\(pvp_, _, target) -> target == mt && matchPVPrefix pvp_ pvpIn ) $ ghcs' forM mResult $ \(pvp_, rest, target) -> do ver' <- pvpToVersion pvp_ rest pure (GHCTargetVersion target ver') -- | Get the latest available ghc for the given PVP version, which -- may only contain parts. -- -- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8|] r -- Just (PVP {_pComponents = 8 :| [10,7]}) -- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8|] r -- Just (PVP {_pComponents = 8 :| [8,4]}) -- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8.4|] r -- Just (PVP {_pComponents = 8 :| [8,4]}) getLatestToolFor :: MonadThrow m => Tool -> PVP -> GHCupDownloads -> m (Maybe (PVP, VersionInfo)) getLatestToolFor tool pvpIn dls = do let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls pure . fmap (first fst) . headMay . filter (\((v, _), _) -> matchPVPrefix pvpIn v) $ ps ----------------- --[ Unpacking ]-- ----------------- -- | Unpack an archive to a temporary directory and return that path. unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -- ^ destination dir -> FilePath -- ^ archive path -> Excepts '[UnknownArchive , ArchiveResult ] m () unpackToDir dfp av = do let fn = takeFileName av lift $ logInfo $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m () untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString rf = liftIO . BL.readFile -- extract, depending on file extension if | ".tar.gz" `isSuffixOf` fn -> liftE (untar . GZip.decompress =<< rf av) | ".tar.xz" `isSuffixOf` fn -> do filecontents <- liftE $ rf av let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents liftE $ untar decompressed | ".tar.bz2" `isSuffixOf` fn -> liftE (untar . BZip.decompress =<< rf av) | ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av) | ".zip" `isSuffixOf` fn -> liftE (untar =<< rf av) | otherwise -> throwE $ UnknownArchive fn getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -- ^ archive path -> Excepts '[UnknownArchive , ArchiveResult ] m [FilePath] getArchiveFiles av = do let fn = takeFileName av let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath] entries = (fmap . fmap) filepath . lE . readArchiveBSL rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString rf = liftIO . BL.readFile -- extract, depending on file extension if | ".tar.gz" `isSuffixOf` fn -> liftE (entries . GZip.decompress =<< rf av) | ".tar.xz" `isSuffixOf` fn -> do filecontents <- liftE $ rf av let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents liftE $ entries decompressed | ".tar.bz2" `isSuffixOf` fn -> liftE (entries . BZip.decompress =<< rf av) | ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av) | ".zip" `isSuffixOf` fn -> liftE (entries =<< rf av) | otherwise -> throwE $ UnknownArchive fn intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m) => FilePath -- ^ unpacked tar dir -> TarDir -- ^ how to descend -> Excepts '[TarDirDoesNotExist] m FilePath intoSubdir bdir tardir = case tardir of RealDir pr -> do whenM (fmap not . liftIO . doesDirectoryExist $ (bdir pr)) (throwE $ TarDirDoesNotExist tardir) pure (bdir pr) RegexDir r -> do let rs = split (`elem` pathSeparators) r foldlM (\y x -> (handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case [] -> throwE $ TarDirDoesNotExist tardir (p : _) -> pure (y p)) . sort ) bdir rs where regex = makeRegexOpts compIgnoreCase execBlank ------------ --[ Tags ]-- ------------ -- | Get the tool version that has this tag. If multiple have it, -- picks the greatest version. getTagged :: Tag -> Fold (Map.Map Version VersionInfo) (Version, VersionInfo) getTagged tag = to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags)) % folding id getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) getLatest av tool = headOf (ix tool % getTagged Latest) av getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) getRecommended av tool = headOf (ix tool % getTagged Recommended) av -- | Gets the latest GHC with a given base version. getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (Version, VersionInfo) getLatestBaseVersion av pvpVer = headOf (ix GHC % getTagged (Base pvpVer)) av ------------- --[ Other ]-- ------------- -- | Usually @~\/.ghcup\/ghc\/\\/bin\/@ ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion -> m FilePath ghcInternalBinDir ver = do ghcdir <- ghcupGHCDir ver pure (ghcdir "bin") -- | Get tool files from @~\/.ghcup\/ghc\/\\/bin\/\*@ -- while ignoring @*-\@ symlinks and accounting for cross triple prefix. -- -- Returns unversioned relative files without extension, e.g.: -- -- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@ ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath] ghcToolFiles ver = do bindir <- ghcInternalBinDir ver -- fail if ghc is not installed whenM (fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir ))) pure (getUniqueTools . groupToolFiles . fmap (dropSuffix exeExt) $ files) where groupToolFiles :: [FilePath] -> [[(FilePath, String)]] groupToolFiles = groupBy (\(a, _) (b, _) -> a == b) . fmap (splitOnPVP "-") getUniqueTools :: [[(FilePath, String)]] -> [String] getUniqueTools = filter (isNotAnyInfix blackListedTools) . nub . fmap fst . filter ((== "") . snd) . concat blackListedTools :: [String] blackListedTools = ["haddock-ghc"] isNotAnyInfix :: [String] -> String -> Bool isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs -- | This file, when residing in @~\/.ghcup\/ghc\/\\/@ signals that -- this GHC was built from source. It contains the build config. ghcUpSrcBuiltFile :: FilePath ghcUpSrcBuiltFile = ".ghcup_src_built" -- | Calls gmake if it exists in PATH, otherwise make. make :: ( MonadThrow m , MonadIO m , MonadReader env m , HasDirs env , HasLog env , HasSettings env ) => [String] -> Maybe FilePath -> m (Either ProcessError ()) make args workdir = do spaths <- liftIO getSearchPath has_gmake <- isJust <$> liftIO (searchPath spaths "gmake") let mymake = if has_gmake then "gmake" else "make" execLogged mymake args workdir "ghc-make" Nothing makeOut :: (MonadReader env m, HasDirs env, MonadIO m) => [String] -> Maybe FilePath -> m CapturedProcess makeOut args workdir = do spaths <- liftIO getSearchPath has_gmake <- isJust <$> liftIO (searchPath spaths "gmake") let mymake = if has_gmake then "gmake" else "make" executeOut mymake args workdir -- | Try to apply patches in order. The order is determined by -- a quilt series file (in the patch directory) if one exists, -- else the patches are applied in lexicographical order. -- Fails with 'PatchFailed' on first failure. applyPatches :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m) => FilePath -- ^ dir containing patches -> FilePath -- ^ dir to apply patches in -> Excepts '[PatchFailed] m () applyPatches pdir ddir = do let lexicographical = (fmap . fmap) (pdir ) $ sort <$> findFiles pdir (makeRegexOpts compExtended execBlank ([s|.+\.(patch|diff)$|] :: ByteString) ) let quilt = map (pdir ) . lines <$> readFile (pdir "series") patches <- liftIO $ quilt `catchIO` (\e -> if isDoesNotExistError e || isPermissionError e then lexicographical else throwIO e) forM_ patches $ \patch' -> applyPatch patch' ddir applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m) => FilePath -- ^ Patch -> FilePath -- ^ dir to apply patches in -> Excepts '[PatchFailed] m () applyPatch patch ddir = do lift $ logInfo $ "Applying patch " <> T.pack patch fmap (either (const Nothing) Just) (exec "patch" ["-p1", "-s", "-f", "-i", patch] (Just ddir) Nothing) !? PatchFailed -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m) => Platform -> FilePath -> m (Either ProcessError ()) darwinNotarization Darwin path = exec "xattr" ["-r", "-d", "com.apple.quarantine", path] Nothing Nothing darwinNotarization _ _ = pure $ Right () getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI getChangeLog dls tool (Left v') = preview (ix tool % ix v' % viChangeLog % _Just) dls getChangeLog dls tool (Right tag) = preview (ix tool % pre (getTagged tag) % to snd % viChangeLog % _Just) dls -- | Execute a build action while potentially cleaning up: -- -- 1. the build directory, depending on the KeepDirs setting -- 2. the install destination, depending on whether the build failed runBuildAction :: ( MonadReader env m , HasDirs env , HasSettings env , MonadIO m , MonadMask m , HasLog env , MonadUnliftIO m , MonadFail m , MonadCatch m ) => FilePath -- ^ build directory (cleaned up depending on Settings) -> Maybe FilePath -- ^ dir to *always* clean up on exception -> Excepts e m a -> Excepts e m a runBuildAction bdir instdir action = do Settings {..} <- lift getSettings let exAction = do forM_ instdir $ \dir -> hideError doesNotExistErrorType $ recyclePathForcibly dir when (keepDirs == Never) $ rmBDir bdir v <- flip onException (lift exAction) $ onE_ exAction action when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir pure v -- | Clean up the given directory if the action fails, -- depending on the Settings. cleanUpOnError :: ( MonadReader env m , HasDirs env , HasSettings env , MonadIO m , MonadMask m , HasLog env , MonadUnliftIO m , MonadFail m , MonadCatch m ) => FilePath -- ^ build directory (cleaned up depending on Settings) -> Excepts e m a -> Excepts e m a cleanUpOnError bdir action = do Settings {..} <- lift getSettings let exAction = when (keepDirs == Never) $ rmBDir bdir flip onException (lift exAction) $ onE_ exAction action -- | Remove a build directory, ignoring if it doesn't exist and gracefully -- printing other errors without crashing. rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m () rmBDir dir = withRunInIO (\run -> run $ liftIO $ handleIO (\e -> run $ logWarn $ "Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e)) $ hideError doesNotExistErrorType $ rmPathForcibly dir) getVersionInfo :: Version -> Tool -> GHCupDownloads -> Maybe VersionInfo getVersionInfo v' tool = headOf ( ix tool % to (Map.filterWithKey (\k _ -> k == v')) % to Map.elems % _head ) -- | The file extension for executables. exeExt :: String exeExt | isWindows = ".exe" | otherwise = "" -- | The file extension for executables. exeExt' :: ByteString exeExt' | isWindows = ".exe" | otherwise = "" -- | On unix, we can use symlinks, so we just get the -- symbolic link target. -- -- On windows, we have to emulate symlinks via shims, -- see 'createLink'. getLinkTarget :: FilePath -> IO FilePath getLinkTarget fp | isWindows = do content <- readFile (dropExtension fp <.> "shim") [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content pure $ stripNewline $ dropPrefix "path = " p | otherwise = getSymbolicLinkTarget fp -- | Checks whether the path is a link. pathIsLink :: FilePath -> IO Bool pathIsLink fp | isWindows = doesPathExist (dropExtension fp <.> "shim") | otherwise = pathIsSymbolicLink fp rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m () rmLink fp | isWindows = do hideError doesNotExistErrorType . recycleFile $ fp hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim") | otherwise = hideError doesNotExistErrorType . recycleFile $ fp -- | Creates a symbolic link on unix and a fake symlink on windows for -- executables, which: -- 1. is a shim exe -- 2. has a corresponding .shim file in the same directory that -- contains the target -- -- This overwrites previously existing files. -- -- On windows, this requires that 'ensureGlobalTools' was run beforehand. createLink :: ( MonadMask m , MonadThrow m , HasLog env , MonadIO m , MonadReader env m , HasDirs env , MonadUnliftIO m , MonadFail m ) => FilePath -- ^ path to the target executable -> FilePath -- ^ path to be created -> m () createLink link exe | isWindows = do dirs <- getDirs let shimGen = cacheDir dirs "gs.exe" let shim = dropExtension exe <.> "shim" -- For hardlinks, link needs to be absolute. -- If link is relative, it's relative to the target exe. -- Note that () drops lhs when rhs is absolute. fullLink = takeDirectory exe link shimContents = "path = " <> fullLink logDebug $ "rm -f " <> T.pack exe rmLink exe logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe liftIO $ copyFile shimGen exe liftIO $ writeFile shim shimContents | otherwise = do logDebug $ "rm -f " <> T.pack exe hideError doesNotExistErrorType $ recycleFile exe logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe liftIO $ createFileLink link exe ensureGlobalTools :: ( MonadMask m , MonadThrow m , HasLog env , MonadIO m , MonadReader env m , HasDirs env , HasSettings env , HasGHCupInfo env , MonadUnliftIO m , MonadFail m ) => Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m () ensureGlobalTools | isWindows = do (GHCupInfo _ _ gTools) <- lift getGHCupInfo dirs <- lift getDirs shimDownload <- liftE $ lE @_ @'[NoDownload] $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools let dl = downloadCached' shimDownload (Just "gs.exe") Nothing void $ (\DigestError{} -> do lift $ logWarn "Digest doesn't match, redownloading gs.exe..." lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs "gs.exe")) lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs "gs.exe") liftE @'[GPGError, DigestError , DownloadFailed] $ dl ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl | otherwise = pure () -- | Ensure ghcup directory structure exists. ensureDirectories :: Dirs -> IO () ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do createDirRecursive' baseDir createDirRecursive' (baseDir "ghc") createDirRecursive' binDir createDirRecursive' cacheDir createDirRecursive' logsDir createDirRecursive' confDir createDirRecursive' trashDir pure () -- | For ghc without arch triple, this is: -- -- - ghc -- -- For ghc with arch triple: -- -- - -ghc (e.g. arm-linux-gnueabihf-ghc) ghcBinaryName :: GHCTargetVersion -> String ghcBinaryName (GHCTargetVersion (Just t) _) = T.unpack (t <> "-ghc" <> T.pack exeExt) ghcBinaryName (GHCTargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt) -- | Does basic checks for isolated installs -- Isolated Directory: -- 1. if it doesn't exist -> proceed -- 2. if it exists and is empty -> proceed -- 3. if it exists and is non-empty -> panic and leave the house installDestSanityCheck :: ( MonadIO m , MonadCatch m ) => InstallDirResolved -> Excepts '[DirNotEmpty] m () installDestSanityCheck (IsolateDirResolved isoDir) = do hideErrorDef [doesNotExistErrorType] () $ do contents <- liftIO $ getDirectoryContentsRecursive isoDir unless (null contents) (throwE $ DirNotEmpty isoDir) installDestSanityCheck _ = pure ()