ghcup-hs/lib/GHCup/Utils.hs

791 lines
25 KiB
Haskell
Raw Normal View History

2020-04-09 17:53:22 +00:00
{-# LANGUAGE CPP #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE OverloadedStrings #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
2020-04-25 10:06:41 +00:00
{-# LANGUAGE ViewPatterns #-}
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
{-|
Module : GHCup.Utils
Description : GHCup domain specific utilities
Copyright : (c) Julian Ospald, 2020
2020-07-30 18:04:02 +00:00
License : LGPL-3.0
2020-07-21 23:08:58 +00:00
Maintainer : hasufell@hasufell.de
Stability : experimental
Portability : POSIX
This module contains GHCup helpers specific to
installation and introspection of files/versions etc.
-}
2020-01-11 20:15:05 +00:00
module GHCup.Utils
( module GHCup.Utils.Dirs
, module GHCup.Utils
)
where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
2020-01-11 20:15:05 +00:00
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
2020-04-25 10:06:41 +00:00
import GHCup.Utils.MegaParsec
2020-01-11 20:15:05 +00:00
import GHCup.Utils.Prelude
2020-04-25 10:06:41 +00:00
import GHCup.Utils.String.QQ
2020-01-11 20:15:05 +00:00
#if !defined(TAR)
import Codec.Archive hiding ( Directory )
#endif
2020-01-11 20:15:05 +00:00
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
2020-04-09 17:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-01-11 20:15:05 +00:00
import Control.Monad.Logger
import Control.Monad.Reader
import Data.ByteString ( ByteString )
2020-04-25 10:06:41 +00:00
import Data.Either
2020-08-06 11:28:20 +00:00
import Data.Foldable
2020-01-11 20:15:05 +00:00
import Data.List
2020-10-24 20:55:35 +00:00
import Data.List.NonEmpty ( NonEmpty( (:|) ))
2020-08-06 11:28:20 +00:00
import Data.List.Split
2020-01-11 20:15:05 +00:00
import Data.Maybe
import Data.String.Interpolate
2020-04-25 10:06:41 +00:00
import Data.Text ( Text )
2020-01-11 20:15:05 +00:00
import Data.Versions
import Data.Word8
import GHC.IO.Exception
import HPath
import HPath.IO hiding ( hideError )
2020-01-11 20:15:05 +00:00
import Haskus.Utils.Variant.Excepts
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import Safe
import System.IO.Error
2020-03-21 21:19:37 +00:00
import System.Posix.FilePath ( getSearchPath
, takeFileName
)
2020-06-20 12:37:38 +00:00
import System.Posix.Files.ByteString ( readSymbolicLink )
2020-04-25 10:06:41 +00:00
import Text.Regex.Posix
2020-01-11 20:15:05 +00:00
import URI.ByteString
#if defined(TAR)
import qualified Codec.Archive.Tar as Tar
#endif
2020-01-11 20:15:05 +00:00
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 as B
import qualified Data.ByteString.Lazy as BL
2020-01-11 20:15:05 +00:00
import qualified Data.Map.Strict as Map
#if !defined(TAR)
import qualified Data.Text as T
#endif
2020-01-11 20:15:05 +00:00
import qualified Data.Text.Encoding as E
2020-04-25 10:06:41 +00:00
import qualified Text.Megaparsec as MP
2020-01-11 20:15:05 +00:00
------------------------
--[ Symlink handling ]--
------------------------
-- | The symlink destination of a ghc tool.
2020-10-23 23:06:53 +00:00
ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
2020-07-28 23:43:00 +00:00
=> ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
2020-04-25 10:06:41 +00:00
-> GHCTargetVersion
2020-07-28 23:43:00 +00:00
-> m ByteString
ghcLinkDestination tool ver = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
2020-07-28 23:43:00 +00:00
t <- parseRel tool
ghcd <- ghcupGHCDir ver
pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
2020-10-23 23:06:53 +00:00
rmMinorSymlinks :: (MonadReader AppState m, MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
2020-04-25 10:06:41 +00:00
rmMinorSymlinks GHCTargetVersion {..} = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
2020-04-25 10:06:41 +00:00
files <- liftIO $ findFiles'
binDir
2020-04-25 10:06:41 +00:00
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk $ prettyVer _tvVersion)
*> (MP.chunk $ prettyVer _tvVersion)
*> MP.eof
)
forM_ files $ \f -> do
let fullF = (binDir </> f)
2020-01-11 20:15:05 +00:00
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
2020-04-25 10:06:41 +00:00
2020-07-21 23:08:58 +00:00
-- | Removes the set ghc version for the given target, if any.
2020-10-23 23:06:53 +00:00
rmPlain :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
2020-04-25 10:06:41 +00:00
=> Maybe Text -- ^ target
2020-01-11 20:15:05 +00:00
-> Excepts '[NotInstalled] m ()
2020-04-25 10:06:41 +00:00
rmPlain target = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- lift ask
mtv <- lift $ ghcSet target
2020-04-25 10:06:41 +00:00
forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do
let fullF = (binDir </> f)
2020-04-25 10:06:41 +00:00
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- old ghcup
let hdc_file = (binDir </> [rel|haddock-ghc|])
2020-04-25 10:06:41 +00:00
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Remove the major GHC symlink, e.g. ghc-8.6.
2020-10-23 23:06:53 +00:00
rmMajorSymlinks :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
-> m ()
rmMajorSymlinks GHCTargetVersion {..} = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
2020-04-25 10:06:41 +00:00
(mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
files <- liftIO $ findFiles'
binDir
2020-04-25 10:06:41 +00:00
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk v')
*> MP.chunk v'
*> MP.eof
)
forM_ files $ \f -> do
let fullF = (binDir </> f)
2020-01-11 20:15:05 +00:00
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-----------------------------------
--[ Set/Installed introspection ]--
-----------------------------------
2020-07-21 23:08:58 +00:00
-- | Whethe the given GHC versin is installed.
2020-10-23 23:06:53 +00:00
ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
2020-01-11 20:15:05 +00:00
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist ghcdir
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Whether the given GHC version is installed from source.
2020-10-23 23:06:53 +00:00
ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
2020-01-11 20:15:05 +00:00
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Whether the given GHC version is set as the current.
2020-10-23 23:06:53 +00:00
ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
2020-04-25 10:06:41 +00:00
=> Maybe Text -- ^ the target of the GHC version, if any
-- (e.g. armv7-unknown-linux-gnueabihf)
-> m (Maybe GHCTargetVersion)
ghcSet mtarget = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
2020-04-25 10:06:41 +00:00
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
let ghcBin = binDir </> ghc
2020-01-11 20:15:05 +00:00
-- link destination is of the form ../ghc/<ver>/bin/ghc
2020-04-25 10:06:41 +00:00
-- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
2020-01-11 20:15:05 +00:00
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link
2020-07-28 23:43:00 +00:00
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
ghcLinkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "ghcLinkVersion" t
2020-04-25 10:06:41 +00:00
where
2020-07-28 23:43:00 +00:00
parser =
(do
_ <- parseUntil1 (MP.chunk "/ghc/")
_ <- MP.chunk "/ghc/"
r <- parseUntil1 (MP.chunk "/")
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* MP.chunk "/"
<* MP.takeRest
<* MP.eof
2020-04-25 10:06:41 +00:00
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left.
2020-10-23 23:06:53 +00:00
getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion]
2020-04-25 10:06:41 +00:00
getInstalledGHCs = do
ghcdir <- ghcupGHCBaseDir
2020-04-25 10:06:41 +00:00
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
forM fs $ \f -> case parseGHCupGHCDir f of
Right r -> pure $ Right r
Left _ -> pure $ Left f
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
2020-10-23 23:06:53 +00:00
getInstalledCabals :: (MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledCabals = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
vs <- forM bins $ \f -> case fmap version (fmap decUTF8Safe . B.stripPrefix "cabal-" . toFilePath $ f) of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
cs <- cabalSet -- for legacy cabal
2020-07-28 19:40:26 +00:00
pure $ maybe vs (\x -> nub $ Right x:vs) cs
2020-07-21 23:08:58 +00:00
-- | Whether the given cabal version is installed.
2020-10-23 23:06:53 +00:00
cabalInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
2020-01-11 20:15:05 +00:00
cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- Return the currently set cabal version, if any.
2020-10-23 23:06:53 +00:00
cabalSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
2020-01-11 20:15:05 +00:00
cabalSet = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> [rel|cabal|]
2020-07-28 23:43:00 +00:00
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if
| b -> do
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
2020-07-28 23:43:00 +00:00
broken <- isBrokenSymlink cabalbin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath cabalbin
Just <$> linkVersion link
| otherwise -> do -- legacy behavior
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (B.null (_stdOut c)), _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
| otherwise -> pure Nothing
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "cabal-" *> version'
2020-01-11 20:15:05 +00:00
-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
2020-10-23 23:06:53 +00:00
getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledHLSs = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
)
vs <- forM bins $ \f ->
case
fmap
version
(fmap decUTF8Safe . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f)
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
pure $ vs
-- | Whether the given HLS version is installed.
2020-10-23 23:06:53 +00:00
hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
hlsInstalled ver = do
vers <- fmap rights $ getInstalledHLSs
pure $ elem ver $ vers
-- Return the currently set hls version, if any.
2020-10-23 23:06:53 +00:00
hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet = do
2020-10-23 23:06:53 +00:00
AppState {dirs = Dirs {..}} <- ask
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
broken <- isBrokenSymlink hlsBin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath hlsBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "haskell-language-server-wrapper-" *> version'
-- | Return the GHC versions the currently selected HLS supports.
2020-10-23 23:06:53 +00:00
hlsGHCVersions :: ( MonadReader AppState m
, MonadIO m
, MonadThrow m
, MonadCatch m
)
=> m [Version]
hlsGHCVersions = do
h <- hlsSet
vers <- forM h $ \h' -> do
bins <- hlsServerBinaries h'
pure $ fmap
(\bin ->
version
. decUTF8Safe
. fromJust
. B.stripPrefix "haskell-language-server-"
. head
. B.split _tilde
. toFilePath
$ bin
)
bins
pure . rights . concat . maybeToList $ vers
-- | Get all server binaries for an hls version, if any.
2020-10-23 23:06:53 +00:00
hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
=> Version
-> m [Path Rel]
hlsServerBinaries ver = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> [s|$|] :: ByteString
)
)
-- | Get the wrapper binary for an hls version, if any.
2020-10-23 23:06:53 +00:00
hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
=> Version
-> m (Maybe (Path Rel))
hlsWrapperBinary ver = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> [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.
2020-10-23 23:06:53 +00:00
hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [Path Rel]
hlsAllBinaries ver = do
hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver
pure (maybeToList wrapper ++ hls)
-- | Get the active symlinks for hls.
2020-10-23 23:06:53 +00:00
hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Path Rel]
hlsSymlinks = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-.*$|] :: ByteString)
)
filterM
( fmap (== SymbolicLink)
. liftIO
. getFileType
. (binDir </>)
)
oldSyms
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
2020-01-11 20:15:05 +00:00
-----------------------------------------
--[ Major version introspection (X.Y) ]--
-----------------------------------------
2020-07-21 23:08:58 +00:00
-- | Extract (major, minor) from any version.
2020-04-25 10:06:41 +00:00
getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
getMajorMinorV Version {..} = case _vChunks of
2020-10-24 20:55:35 +00:00
((Digits x :| []) :| ((Digits y :| []):_)) -> pure (fromIntegral x, fromIntegral y)
2020-04-25 10:06:41 +00:00
_ -> 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
2020-01-11 20:15:05 +00:00
-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
2020-10-23 23:06:53 +00:00
getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m)
2020-04-25 10:06:41 +00:00
=> Int -- ^ major version component
-> Int -- ^ minor version component
-> Maybe Text -- ^ the target triple
-> m (Maybe GHCTargetVersion)
getGHCForMajor major' minor' mt = do
ghcs <- rights <$> getInstalledGHCs
pure
2020-01-11 20:15:05 +00:00
. lastMay
2020-04-25 10:06:41 +00:00
. sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
2020-01-11 20:15:05 +00:00
. filter
2020-04-25 10:06:41 +00:00
(\GHCTargetVersion {..} ->
_tvTarget == mt && matchMajor _tvVersion major' minor'
2020-01-11 20:15:05 +00:00
)
2020-04-25 10:06:41 +00:00
$ ghcs
2020-01-11 20:15:05 +00:00
2020-04-22 14:13:58 +00:00
-- | Get the latest available ghc for X.Y major version.
getLatestGHCFor :: Int -- ^ major version component
-> Int -- ^ minor version component
-> GHCupDownloads
-> Maybe Version
getLatestGHCFor major' minor' dls = do
2020-04-25 10:06:41 +00:00
join
. fmap (lastMay . filter (\v -> matchMajor v major' minor'))
. preview (ix GHC % to Map.keys)
$ dls
2020-04-22 14:13:58 +00:00
2020-01-11 20:15:05 +00:00
-----------------
--[ Unpacking ]--
-----------------
-- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ destination dir
-> Path Abs -- ^ archive path
-> Excepts '[UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
] m ()
2020-01-11 20:15:05 +00:00
unpackToDir dest av = do
2020-04-17 07:30:45 +00:00
fp <- (decUTF8Safe . toFilePath) <$> basename av
let dfp = decUTF8Safe . toFilePath $ dest
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
2020-01-11 20:15:05 +00:00
fn <- toFilePath <$> basename av
#if defined(TAR)
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
2020-07-30 18:04:37 +00:00
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
rf = liftIO . readFile
#else
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
rf = liftIO . readFile
2020-07-30 18:04:37 +00:00
#endif
2020-01-11 20:15:05 +00:00
-- extract, depending on file extension
if
| ".tar.gz" `B.isSuffixOf` fn -> liftE
(untar . GZip.decompress =<< rf av)
2020-03-21 21:19:37 +00:00
| ".tar.xz" `B.isSuffixOf` fn -> do
filecontents <- liftE $ rf av
2020-01-11 20:15:05 +00:00
let decompressed = Lzma.decompress filecontents
liftE $ untar decompressed
| ".tar.bz2" `B.isSuffixOf` fn ->
liftE (untar . BZip.decompress =<< rf av)
| ".tar" `B.isSuffixOf` fn -> liftE (untar =<< rf av)
2020-01-11 20:15:05 +00:00
| otherwise -> throwE $ UnknownArchive fn
2020-08-06 11:28:20 +00:00
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
=> Path Abs -- ^ unpacked tar dir
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m (Path Abs)
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 = splitOn "/" r
foldlM
(\y x ->
(fmap sort . handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= \case
[] -> throwE $ TarDirDoesNotExist tardir
(p : _) -> pure (y </> p)
)
bdir
rs
where regex = makeRegexOpts compIgnoreCase execBlank
2020-01-11 20:15:05 +00:00
------------
--[ Tags ]--
------------
-- | Get the tool version that has this tag. If multiple have it,
-- picks the greatest version.
2020-04-25 10:06:41 +00:00
getTagged :: Tag
-> AffineFold (Map.Map Version VersionInfo) (Version, VersionInfo)
getTagged tag =
( to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
% to Map.toDescList
% _head
2020-01-11 20:15:05 +00:00
)
getLatest :: GHCupDownloads -> Tool -> Maybe Version
getLatest av tool = headOf (ix tool % getTagged Latest % to fst) $ av
2020-01-11 20:15:05 +00:00
getRecommended :: GHCupDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf (ix tool % getTagged Recommended % to fst) $ av
2020-01-11 20:15:05 +00:00
2020-04-22 00:33:35 +00:00
-- | Gets the latest GHC with a given base version.
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe Version
2020-04-25 10:06:41 +00:00
getLatestBaseVersion av pvpVer =
headOf (ix GHC % getTagged (Base pvpVer) % to fst) av
2020-04-22 00:33:35 +00:00
2020-01-11 20:15:05 +00:00
-----------------------
2020-10-23 23:06:53 +00:00
--[ AppState Getter ]--
2020-01-11 20:15:05 +00:00
-----------------------
2020-10-23 23:06:53 +00:00
getCache :: MonadReader AppState m => m Bool
getCache = ask <&> cache . settings
2020-01-11 20:15:05 +00:00
2020-10-23 23:06:53 +00:00
getDownloader :: MonadReader AppState m => m Downloader
getDownloader = ask <&> downloader . settings
2020-04-29 17:12:58 +00:00
2020-01-11 20:15:05 +00:00
-------------
--[ Other ]--
-------------
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
2020-07-21 23:08:58 +00:00
-- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
2020-01-11 20:15:05 +00:00
--
-- Returns unversioned relative files, e.g.:
2020-07-21 23:08:58 +00:00
--
-- - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
2020-10-23 23:06:53 +00:00
ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
2020-04-25 10:06:41 +00:00
=> GHCTargetVersion
2020-01-11 20:15:05 +00:00
-> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do
ghcdir <- lift $ ghcupGHCDir ver
2020-01-11 20:15:05 +00:00
let bindir = ghcdir </> [rel|bin|]
-- fail if ghc is not installed
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
2020-04-25 10:06:41 +00:00
(throwE (NotInstalled GHC (prettyTVer ver)))
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
files <- liftIO $ getDirsFiles' bindir
2020-01-11 20:15:05 +00:00
-- figure out the <ver> suffix, because this might not be `Version` for
-- alpha/rc releases, but x.y.a.somedate.
2020-04-25 10:06:41 +00:00
-- for cross, this won't be "ghc", but e.g.
-- "armv7-unknown-linux-gnueabihf-ghc"
[ghcbin] <- liftIO $ findFiles
bindir
(makeRegexOpts compExtended
execBlank
([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString)
)
2020-06-20 12:37:38 +00:00
let ghcbinPath = bindir </> ghcbin
ghcIsHadrian <- liftIO $ isHadrian ghcbinPath
onlyUnversioned <- if ghcIsHadrian
then pure id
else do
(Just symver) <-
(B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName)
2020-06-20 12:37:38 +00:00
<$> (liftIO $ readSymbolicLink $ toFilePath ghcbinPath)
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x)
pure $ onlyUnversioned files
2020-06-20 12:37:38 +00:00
where
-- GHC is moving some builds to Hadrian for bindists,
-- which doesn't create versioned binaries.
-- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
2020-06-20 12:37:38 +00:00
isHadrian :: Path Abs -- ^ ghcbin path
-> IO Bool
isHadrian = fmap (/= SymbolicLink) . getFileType
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
-- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
2020-01-11 20:15:05 +00:00
-- this GHC was built from source. It contains the build config.
ghcUpSrcBuiltFile :: Path Rel
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
-- | Calls gmake if it exists in PATH, otherwise make.
2020-10-23 23:06:53 +00:00
make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
2020-07-13 09:52:34 +00:00
=> [ByteString]
-> Maybe (Path Abs)
-> m (Either ProcessError ())
make args workdir = do
2020-07-13 09:52:34 +00:00
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
2020-03-21 21:19:37 +00:00
let mymake = if has_gmake then "gmake" else "make"
2020-03-24 15:49:18 +00:00
execLogged mymake True args [rel|ghc-make|] workdir Nothing
-- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure.
applyPatches :: (MonadLogger m, MonadIO m)
=> Path Abs -- ^ dir containing patches
-> Path Abs -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m ()
applyPatches pdir ddir = do
patches <- liftIO $ getDirsFiles pdir
forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) [i|Applying patch #{patch'}|]
(fmap (either (const Nothing) Just) $ liftIO $ exec
"patch"
True
["-p1", "-i", toFilePath patch']
(Just ddir)
Nothing
)
!? PatchFailed
2020-04-10 17:27:17 +00:00
2020-07-21 23:08:58 +00:00
-- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
2020-04-10 17:27:17 +00:00
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
darwinNotarization Darwin path = exec
"xattr"
True
["-r", "-d", "com.apple.quarantine", toFilePath 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
2020-04-25 10:06:41 +00:00
getChangeLog dls tool (Right tag) =
preview (ix tool % getTagged tag % to snd % viChangeLog % _Just) dls
2020-04-22 16:12:40 +00:00
-- | 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
2020-10-23 23:06:53 +00:00
runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m)
=> Path Abs -- ^ build directory (cleaned up depending on Settings)
-> Maybe (Path Abs) -- ^ dir to *always* clean up on exception
-> Excepts e m a
-> Excepts '[BuildFailed] m a
2020-04-22 16:12:40 +00:00
runBuildAction bdir instdir action = do
2020-10-23 23:06:53 +00:00
AppState { settings = Settings {..} } <- lift ask
2020-07-31 18:10:40 +00:00
let exAction = do
2020-04-22 16:12:40 +00:00
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ deleteDirRecursive bdir
2020-07-31 18:10:40 +00:00
v <-
flip onException exAction
2020-04-22 16:12:40 +00:00
$ catchAllE
(\es -> do
2020-07-31 18:10:40 +00:00
exAction
2020-04-22 16:12:40 +00:00
throwE (BuildFailed bdir es)
)
$ action
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
bdir
pure v
-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
createDirRecursive' :: Path b -> IO ()
createDirRecursive' p =
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
. createDirRecursive newDirPerms
$ p
where
isSymlinkDir e = do
ft <- getFileType p
case ft of
SymbolicLink -> do
rp <- canonicalizePath p
rft <- getFileType rp
case rft of
Directory -> pure ()
_ -> throwIO e
_ -> throwIO e