Initial commit
This commit is contained in:
330
lib/GHCup/Utils.hs
Normal file
330
lib/GHCup/Utils.hs
Normal file
@@ -0,0 +1,330 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module GHCup.Utils
|
||||
( module GHCup.Utils.Dirs
|
||||
, module GHCup.Utils
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.Attoparsec.ByteString
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
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
|
||||
import System.Posix.FilePath ( takeFileName )
|
||||
import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
------------------------
|
||||
--[ Symlink handling ]--
|
||||
------------------------
|
||||
|
||||
|
||||
-- | The symlink destination of a ghc tool.
|
||||
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> Version
|
||||
-> ByteString
|
||||
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
|
||||
|
||||
|
||||
-- | Extract the version part of the result of `ghcLinkDestination`.
|
||||
ghcLinkVersion :: MonadThrow m => ByteString -> m Version
|
||||
ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
|
||||
where
|
||||
parser = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
|
||||
verParser = many1' (notWord8 _slash) >>= \t ->
|
||||
case version $ E.decodeUtf8 $ B.pack t of
|
||||
Left e -> fail $ show e
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
-- e.g. ghc-8.6.5
|
||||
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => Version -> m ()
|
||||
rmMinorSymlinks ver = do
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
let myfiles =
|
||||
filter (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x) files
|
||||
forM_ myfiles $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
-- E.g. ghc, if this version is the set one.
|
||||
-- This reads `ghcupGHCDir`.
|
||||
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmPlain ver = do
|
||||
files <- liftE $ ghcToolFiles ver
|
||||
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
|
||||
|
||||
-- e.g. ghc-8.6
|
||||
rmMajorSymlinks :: (MonadLogger m, MonadIO m) => Version -> m ()
|
||||
rmMajorSymlinks ver = do
|
||||
(mj, mi) <- liftIO $ getGHCMajor ver
|
||||
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
|
||||
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
let myfiles = filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
|
||||
forM_ myfiles $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------------------------
|
||||
--[ Set/Installed introspection ]--
|
||||
-----------------------------------
|
||||
|
||||
|
||||
toolAlreadyInstalled :: Tool -> Version -> IO Bool
|
||||
toolAlreadyInstalled tool ver = case tool of
|
||||
GHC -> ghcInstalled ver
|
||||
Cabal -> cabalInstalled ver
|
||||
GHCup -> pure True
|
||||
|
||||
|
||||
ghcInstalled :: Version -> IO Bool
|
||||
ghcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesDirectoryExist ghcdir
|
||||
|
||||
|
||||
ghcSrcInstalled :: Version -> IO Bool
|
||||
ghcSrcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
||||
|
||||
|
||||
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
|
||||
ghcSet = do
|
||||
ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
|
||||
-- link destination is of the form ../ghc/<ver>/bin/ghc
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
link <- readSymbolicLink $ toFilePath ghcBin
|
||||
Just <$> ghcLinkVersion link
|
||||
|
||||
|
||||
cabalInstalled :: Version -> IO Bool
|
||||
cabalInstalled ver = do
|
||||
reportedVer <- cabalSet
|
||||
pure (reportedVer == ver)
|
||||
|
||||
cabalSet :: (MonadIO m, MonadThrow m) => m Version
|
||||
cabalSet = do
|
||||
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
mc <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
|
||||
case version (E.decodeUtf8 reportedVer) of
|
||||
Left e -> throwM e
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
|
||||
-----------------------------------------
|
||||
--[ Major version introspection (X.Y) ]--
|
||||
-----------------------------------------
|
||||
|
||||
|
||||
-- | We assume GHC is in semver format. I hope it is.
|
||||
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
|
||||
getGHCMajor ver = do
|
||||
SemVer {..} <- throwEither (semver $ prettyVer ver)
|
||||
pure (fromIntegral _svMajor, fromIntegral _svMinor)
|
||||
|
||||
|
||||
-- | Get the latest installed full GHC version that satisfies X.Y.
|
||||
-- This reads `ghcupGHCBaseDir`.
|
||||
getGHCForMajor :: (MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> m (Maybe Version)
|
||||
getGHCForMajor major' minor' = do
|
||||
p <- liftIO $ ghcupGHCBaseDir
|
||||
ghcs <- liftIO $ getDirsFiles' p
|
||||
semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
|
||||
mapM (throwEither . version)
|
||||
. fmap prettySemVer
|
||||
. lastMay
|
||||
. sort
|
||||
. filter
|
||||
(\SemVer {..} ->
|
||||
fromIntegral _svMajor == major' && fromIntegral _svMinor == minor'
|
||||
)
|
||||
$ semvers
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ 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
|
||||
let fp = E.decodeUtf8 (toFilePath av)
|
||||
lift $ $(logInfo) [i|Unpacking: #{fp}|]
|
||||
fn <- toFilePath <$> basename av
|
||||
let untar = Tar.unpack (toFilePath dest) . Tar.read
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . GZip.decompress =<< readFile av)
|
||||
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
|
||||
filecontents <- liftIO $ readFile av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftIO $ untar decompressed
|
||||
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . BZip.decompress =<< readFile av)
|
||||
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
|
||||
|
||||
|
||||
------------
|
||||
--[ Tags ]--
|
||||
------------
|
||||
|
||||
|
||||
-- | Get the tool versions that have this tag.
|
||||
getTagged :: GHCupDownloads -> Tool -> Tag -> [Version]
|
||||
getTagged av tool tag = toListOf
|
||||
( ix tool
|
||||
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
|
||||
% to Map.keys
|
||||
% folded
|
||||
)
|
||||
av
|
||||
|
||||
getLatest :: GHCupDownloads -> Tool -> Maybe Version
|
||||
getLatest av tool = headOf folded $ getTagged av tool Latest
|
||||
|
||||
getRecommended :: GHCupDownloads -> Tool -> Maybe Version
|
||||
getRecommended av tool = headOf folded $ getTagged av tool Recommended
|
||||
|
||||
|
||||
|
||||
-----------------------
|
||||
--[ Settings Getter ]--
|
||||
-----------------------
|
||||
|
||||
|
||||
getUrlSource :: MonadReader Settings m => m URLSource
|
||||
getUrlSource = ask <&> urlSource
|
||||
|
||||
getCache :: MonadReader Settings m => m Bool
|
||||
getCache = ask <&> cache
|
||||
|
||||
|
||||
|
||||
-------------
|
||||
--[ Other ]--
|
||||
-------------
|
||||
|
||||
|
||||
urlBaseName :: MonadThrow m
|
||||
=> ByteString -- ^ the url path (without scheme and host)
|
||||
-> m (Path Rel)
|
||||
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||
|
||||
|
||||
-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
|
||||
-- while ignoring *-<ver> symlinks.
|
||||
--
|
||||
-- Returns unversioned relative files, e.g.:
|
||||
-- ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
|
||||
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> 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)
|
||||
(throwE (NotInstalled GHC ver))
|
||||
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
-- figure out the <ver> suffix, because this might not be `Version` for
|
||||
-- alpha/rc releases, but x.y.a.somedate.
|
||||
(Just symver) <-
|
||||
(B.stripPrefix [s|ghc-|] . takeFileName)
|
||||
<$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> [rel|ghc|]))
|
||||
when (B.null symver)
|
||||
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
|
||||
|
||||
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
|
||||
|
||||
|
||||
-- | 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|]
|
||||
Reference in New Issue
Block a user