ghcup-hs/lib/GHCup/Utils.hs

530 lines
16 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
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
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-01-11 20:15:05 +00:00
import Data.List
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
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
import qualified Codec.Archive.Tar as Tar
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.Map.Strict as Map
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.
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
2020-04-25 10:06:41 +00:00
-> GHCTargetVersion
2020-01-11 20:15:05 +00:00
-> ByteString
2020-04-25 10:06:41 +00:00
ghcLinkDestination tool ver =
"../ghc/" <> E.encodeUtf8 (prettyTVer ver) <> "/bin/" <> tool
2020-01-11 20:15:05 +00:00
-- e.g. ghc-8.6.5
2020-04-25 10:06:41 +00:00
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => GHCTargetVersion -> m ()
rmMinorSymlinks GHCTargetVersion {..} = do
2020-01-11 20:15:05 +00:00
bindir <- liftIO $ ghcupBinDir
2020-04-25 10:06:41 +00:00
files <- liftIO $ findFiles'
bindir
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk $ prettyVer _tvVersion)
*> (MP.chunk $ prettyVer _tvVersion)
*> MP.eof
)
forM_ files $ \f -> do
2020-01-11 20:15:05 +00:00
let fullF = (bindir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
2020-04-25 10:06:41 +00:00
-- Removes the set ghc version for the given target, if any.
2020-01-11 20:15:05 +00:00
rmPlain :: (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
mtv <- ghcSet target
forM_ mtv $ \tv -> do
files <- liftE $ ghcToolFiles tv
bindir <- liftIO $ ghcupBinDir
forM_ files $ \f -> do
let fullF = (bindir </> f)
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- old ghcup
let hdc_file = (bindir </> [rel|haddock-ghc|])
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
2020-01-11 20:15:05 +00:00
-- e.g. ghc-8.6
2020-04-25 10:06:41 +00:00
rmMajorSymlinks :: (MonadThrow m, MonadLogger m, MonadIO m)
=> GHCTargetVersion
-> m ()
rmMajorSymlinks GHCTargetVersion {..} = do
(mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi
2020-01-11 20:15:05 +00:00
bindir <- liftIO ghcupBinDir
2020-04-25 10:06:41 +00:00
files <- liftIO $ findFiles'
bindir
( maybe mempty (\x -> MP.chunk (x <> "-")) _tvTarget
*> parseUntil1 (MP.chunk v')
*> MP.chunk v'
*> MP.eof
)
forM_ files $ \f -> do
2020-01-11 20:15:05 +00:00
let fullF = (bindir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-----------------------------------
--[ Set/Installed introspection ]--
-----------------------------------
2020-04-25 10:06:41 +00:00
ghcInstalled :: GHCTargetVersion -> IO Bool
2020-01-11 20:15:05 +00:00
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir
2020-04-25 10:06:41 +00:00
ghcSrcInstalled :: GHCTargetVersion -> IO Bool
2020-01-11 20:15:05 +00:00
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
2020-04-25 10:06:41 +00:00
ghcSet :: (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
ghc <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
ghcBin <- (</> ghc) <$> liftIO ghcupBinDir
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-04-25 10:06:41 +00:00
where
ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
ghcLinkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "../ghc/"
*> (do
r <- parseUntil1 (MP.chunk "/")
rest <- MP.getInput
MP.setInput r
x <- ghcTargetVerP
MP.setInput rest
pure x
)
<* MP.chunk "/"
<* MP.takeRest
<* MP.eof
-- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
-- If a dir cannot be parsed, returns left.
getInstalledGHCs :: MonadIO m => m [Either (Path Rel) GHCTargetVersion]
getInstalledGHCs = do
ghcdir <- liftIO $ ghcupGHCBaseDir
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
getInstalledCabals :: IO [Either (Path Rel) Version]
getInstalledCabals = do
bindir <- liftIO $ ghcupBinDir
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
pure $ maybe vs (\x -> Right x:vs) cs
2020-01-11 20:15:05 +00:00
cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
vers <- fmap rights $ getInstalledCabals
pure $ elem ver $ vers
2020-01-11 20:15:05 +00:00
cabalSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
2020-01-11 20:15:05 +00:00
cabalSet = do
2020-03-16 09:47:09 +00:00
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
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
2020-01-11 20:15:05 +00:00
-----------------------------------------
--[ Major version introspection (X.Y) ]--
-----------------------------------------
2020-04-25 10:06:41 +00:00
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
2020-01-11 20:15:05 +00:00
-- | Get the latest installed full GHC version that satisfies X.Y.
-- This reads `ghcupGHCBaseDir`.
getGHCForMajor :: (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] m ()
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
let untar = Tar.unpack (toFilePath dest) . Tar.read
-- extract, depending on file extension
if
2020-03-21 21:19:37 +00:00
| ".tar.gz" `B.isSuffixOf` fn -> liftIO
2020-01-11 20:15:05 +00:00
(untar . GZip.decompress =<< readFile av)
2020-03-21 21:19:37 +00:00
| ".tar.xz" `B.isSuffixOf` fn -> do
2020-01-11 20:15:05 +00:00
filecontents <- liftIO $ readFile av
let decompressed = Lzma.decompress filecontents
liftIO $ untar decompressed
2020-03-21 21:19:37 +00:00
| ".tar.bz2" `B.isSuffixOf` fn -> liftIO
2020-01-11 20:15:05 +00:00
(untar . BZip.decompress =<< readFile av)
2020-03-21 21:19:37 +00:00
| ".tar" `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
2020-01-11 20:15:05 +00:00
| otherwise -> throwE $ UnknownArchive fn
------------
--[ 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
-----------------------
--[ Settings Getter ]--
-----------------------
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache
2020-04-29 17:12:58 +00:00
getDownloader :: MonadReader Settings m => m Downloader
getDownloader = ask <&> downloader
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-04-09 17:53:22 +00:00
-- Get tool files from '~/.ghcup/bin/ghc/<ver>/bin/*'
2020-04-25 10:06:41 +00:00
-- while ignoring *-<ver> symlinks and accounting for cross triple prefix.
2020-01-11 20:15:05 +00:00
--
-- Returns unversioned relative files, e.g.:
-- ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
ghcToolFiles :: (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 <- liftIO $ ghcupGHCDir ver
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
-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
-- 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.
make :: [ByteString] -> Maybe (Path Abs) -> IO (Either ProcessError ())
make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> getSearchPath
has_gmake <- isJust <$> 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
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
runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
=> Path Abs -- ^ build directory
-> Maybe (Path Abs) -- ^ install location (e.g. for GHC)
-> Excepts e m a
-> Excepts '[BuildFailed] m a
2020-04-22 16:12:40 +00:00
runBuildAction bdir instdir action = do
Settings {..} <- lift ask
v <- flip
2020-04-22 16:12:40 +00:00
onException
(do
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ deleteDirRecursive bdir
)
$ catchAllE
(\es -> do
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ deleteDirRecursive bdir
throwE (BuildFailed bdir es)
)
$ action
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
bdir
pure v