hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Jo

Browse Source
This commit is contained in:
Julian Ospald
2020-03-08 18:30:08 +01:00
parent b2a7da29cf
commit 18f891f261
20 changed files with 2652 additions and 1995 deletions
Download Patch File Download Diff File Expand all files Collapse all files

242
lib/GHCup/Download.hs
View File

@@ -4,6 +4,7 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.Download where
@@ -33,6 +34,7 @@ import Data.ByteString.Builder
import Data.IORef
import Data.Maybe
import Data.String.Interpolate
import Data.Text.Read
import Data.Versions
import GHC.IO.Exception
import HPath
@@ -52,9 +54,12 @@ import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite )
import System.Posix.RawFilePath.Directory.Errors
( hideError )
import System.ProgressBar
import URI.ByteString
import URI.ByteString.QQ
import qualified Data.Binary.Builder as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified Data.Text.Encoding as E
import qualified System.IO.Streams as Streams
@@ -69,6 +74,11 @@ ghcupURL =
------------------
--[ High-level ]--
------------------
-- | Downloads the download information!
getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version
@@ -78,19 +88,16 @@ getDownloads :: ( FromJSONKey Tool
, MonadReader Settings m
, MonadLogger m
)
=> Excepts
'[FileDoesNotExistError , URLException , JSONError]
m
GHCupDownloads
=> Excepts '[JSONError , DownloadFailed] m GHCupDownloads
getDownloads = do
urlSource <- lift getUrlSource
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
case urlSource of
GHCupURL -> do
bs <- liftE $ downloadBS ghcupURL
bs <- reThrowAll DownloadFailed $ downloadBS ghcupURL
lE' JSONDecodeError $ eitherDecode' bs
(OwnSource url) -> do
bs <- liftE $ downloadBS url
bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av
@@ -101,18 +108,19 @@ getDownloadInfo :: ( MonadLogger m
, MonadIO m
, MonadReader Settings m
)
=> BinaryDownloads
-> ToolRequest
=> GHCupDownloads
-> Tool
-> Version
-> Maybe PlatformRequest
-> Excepts
'[ DistroNotFound
, PlatformResultError
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload
]
m
DownloadInfo
getDownloadInfo bDls (ToolRequest t v) mpfReq = do
getDownloadInfo bDls t v mpfReq = do
(PlatformRequest arch' plat ver) <- case mpfReq of
Just x -> pure x
Nothing -> do
@@ -132,7 +140,7 @@ getDownloadInfo' :: Tool
-- ^ user platform
-> Maybe Versioning
-- ^ optional version of the platform
-> BinaryDownloads
-> GHCupDownloads
-> Either NoDownload DownloadInfo
getDownloadInfo' t v a p mv dls = maybe
(Left NoDownload)
@@ -155,15 +163,21 @@ getDownloadInfo' t v a p mv dls = maybe
-- 2. otherwise create a random file
--
-- The file must not exist.
download :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
download :: ( MonadMask m
, MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> DownloadInfo
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , URLException] m (Path Abs)
download dli dest mfn | scheme == [s|https|] = dl True
| scheme == [s|http|] = dl False
| scheme == [s|file|] = cp
| otherwise = throwE UnsupportedURL
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
download dli dest mfn
| scheme == [s|https|] = dl
| scheme == [s|http|] = dl
| scheme == [s|file|] = cp
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
where
scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
@@ -174,16 +188,12 @@ download dli dest mfn | scheme == [s|https|] = dl True
fromFile <- parseAbs path
liftIO $ copyFile fromFile destFile Strict
pure destFile
dl https = do
dl = do
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
lift $ $(logInfo) [i|downloading: #{uri'}|]
host <-
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
?? UnsupportedURL
let port = preview
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
dli
(https, host, fullPath, port) <- reThrowAll DownloadFailed
$ uriToQuadruple (view dlUri dli)
-- destination dir must exist
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
@@ -192,11 +202,9 @@ download dli dest mfn | scheme == [s|https|] = dl True
-- download
fd <- liftIO $ createRegularFileFd newFilePerms destFile
let stepper = fdWrite fd
liftIO $ flip finally (closeFd fd) $ downloadInternal https
host
path
port
stepper
flip finally (liftIO $ closeFd fd)
$ reThrowAll DownloadFailed
$ downloadInternal True https host fullPath port stepper
-- TODO: verify md5 during download
liftE $ checkDigest dli destFile
@@ -211,7 +219,8 @@ download dli dest mfn | scheme == [s|https|] = dl True
-- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url.
downloadCached :: ( MonadResource m
downloadCached :: ( MonadMask m
, MonadResource m
, MonadThrow m
, MonadLogger m
, MonadIO m
@@ -219,7 +228,7 @@ downloadCached :: ( MonadResource m
)
=> DownloadInfo
-> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , URLException] m (Path Abs)
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
downloadCached dli mfn = do
cache <- lift getCache
case cache of
@@ -238,11 +247,24 @@ downloadCached dli mfn = do
liftE $ download dli tmp mfn
------------------
--[ Low-level ]--
------------------
-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m)
=> URI
-> Excepts
'[FileDoesNotExistError , URLException]
'[ FileDoesNotExistError
, HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m
L.ByteString
downloadBS uri'
@@ -251,10 +273,10 @@ downloadBS uri'
| scheme == [s|http|]
= dl False
| scheme == [s|file|]
= liftException doesNotExistErrorType (FileDoesNotExistError path)
$ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString)
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
$ (liftIO $ RD.readFile path)
| otherwise
= throwE UnsupportedURL
= throwE UnsupportedScheme
where
scheme = view (uriSchemeL' % schemeBSL') uri'
@@ -262,55 +284,144 @@ downloadBS uri'
dl https = do
host <-
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
?? UnsupportedURL
?? UnsupportedScheme
let port = preview
(authorityL' % _Just % authorityPortL' % _Just % portNumberL')
uri'
liftIO $ downloadBS' https host path port
liftE $ downloadBS' https host path port
-- | Load the result of this download into memory at once.
downloadBS' :: Bool -- ^ https?
downloadBS' :: MonadIO m
=> Bool -- ^ https?
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> ByteString -- ^ path (e.g. "/my/file") including query
-> Maybe Int -- ^ optional port (e.g. 3000)
-> IO (L.ByteString)
-> Excepts
'[ HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m
(L.ByteString)
downloadBS' https host path port = do
bref <- newIORef (mempty :: Builder)
bref <- liftIO $ newIORef (mempty :: Builder)
let stepper bs = modifyIORef bref (<> byteString bs)
downloadInternal https host path port stepper
readIORef bref <&> toLazyByteString
downloadInternal False https host path port stepper
liftIO (readIORef bref <&> toLazyByteString)
downloadInternal :: Bool
-> ByteString
-> ByteString
-> Maybe Int
-> (ByteString -> IO a) -- ^ the consuming step function
-> IO ()
downloadInternal https host path port consumer = do
c <- case https of
True -> do
ctx <- baselineContextSSL
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
downloadInternal :: MonadIO m
=> Bool -- ^ whether to show a progress bar
-> Bool -- ^ https?
-> ByteString -- ^ host
-> ByteString -- ^ path with query
-> Maybe Int -- ^ optional port
-> (ByteString -> IO a) -- ^ the consuming step function
-> Excepts
'[ HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m
()
downloadInternal = go (5 :: Int)
let q = buildRequest1 $ http GET path
where
go redirs progressBar https host path port consumer = do
r <- liftIO $ bracket acquire release' action
veitherToExcepts r >>= \case
Just r' ->
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
Nothing -> pure ()
where
acquire = case https of
True -> do
ctx <- baselineContextSSL
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
sendRequest c q emptyBody
release' = closeConnection
receiveResponse
c
(\_ i' -> do
outStream <- Streams.makeOutputStream
action c = do
let q = buildRequest1 $ http GET path
sendRequest c q emptyBody
receiveResponse
c
(\r i' -> runE $ do
let scode = getStatusCode r
if
| scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
| scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
Just r' -> pure $ Just $ r'
Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode
)
followRedirectURL bs = case parseURI strictURIParserOptions bs of
Right uri' -> do
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
go (redirs - 1) progressBar https' host' fullPath' port' consumer
Left e -> throwE e
downloadStream r i' = do
let size = case getHeader r [s|Content-Length|] of
Just x' -> case decimal $ E.decodeUtf8 x' of
Left _ -> 0
Right (r', _) -> r'
Nothing -> 0
mpb <- if progressBar
then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
else pure Nothing
outStream <- liftIO $ Streams.makeOutputStream
(\case
Just bs -> void $ consumer bs
Just bs -> do
forM_ mpb $ \pb -> incProgress pb (BS.length bs)
void $ consumer bs
Nothing -> pure ()
)
Streams.connect i' outStream
)
liftIO $ Streams.connect i' outStream
closeConnection c
-- | Extracts from a URI type: (https?, host, path+query, port)
uriToQuadruple :: Monad m
=> URI
-> Excepts
'[UnsupportedScheme]
m
(Bool, ByteString, ByteString, Maybe Int)
uriToQuadruple URI {..} = do
let scheme = view schemeBSL' uriScheme
host <-
preview (_Just % authorityHostL' % hostBSL') uriAuthority
?? UnsupportedScheme
https <- if
| scheme == [s|https|] -> pure True
| scheme == [s|http|] -> pure False
| otherwise -> throwE UnsupportedScheme
let
queryBS =
BS.intercalate [s|&|]
. fmap (\(x, y) -> encodeQuery x <> [s|=|] <> encodeQuery y)
$ (queryPairs uriQuery)
port =
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
fullpath =
if BS.null queryBS then uriPath else uriPath <> [s|?|] <> queryBS
pure (https, host, fullpath, port)
where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery
checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m)
@@ -326,4 +437,3 @@ checkDigest dli file = do
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
eDigest = view dlHash dli
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)

103
lib/GHCup/Errors.hs
View File

@@ -1,3 +1,8 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
module GHCup.Errors where
import GHCup.Types
@@ -5,59 +10,115 @@ import GHCup.Types
import Control.Exception.Safe
import Data.ByteString ( ByteString )
import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant
import HPath
------------------------
--[ Low-level errors ]--
------------------------
-- | A compatible platform could not be found.
data PlatformResultError = NoCompatiblePlatform String -- the platform we got
data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got
deriving Show
-- | Unable to find a download for the requested versio/distro.
data NoDownload = NoDownload
deriving Show
-- | The Architecture is unknown and unsupported.
data NoCompatibleArch = NoCompatibleArch String
deriving Show
-- | Unable to figure out the distribution of the host.
data DistroNotFound = DistroNotFound
deriving Show
data ArchiveError = UnknownArchive ByteString
-- | The archive format is unknown. We don't know how to extract it.
data UnknownArchive = UnknownArchive ByteString
deriving Show
data URLException = UnsupportedURL
-- | The scheme is not supported (such as ftp).
data UnsupportedScheme = UnsupportedScheme
deriving Show
data FileError = CopyError String
-- | Unable to copy a file.
data CopyError = CopyError String
deriving Show
-- | Unable to find a tag of a tool.
data TagNotFound = TagNotFound Tag Tool
deriving Show
data AlreadyInstalled = AlreadyInstalled ToolRequest
-- | The tool (such as GHC) is already installed with that version.
data AlreadyInstalled = AlreadyInstalled Tool Version
deriving Show
data NotInstalled = NotInstalled ToolRequest
deriving Show
data NotSet = NotSet Tool
-- | The tool is not installed. Some operations rely on a tool
-- to be installed (such as setting the current GHC version).
data NotInstalled = NotInstalled Tool Version
deriving Show
-- | JSON decoding failed.
data JSONError = JSONDecodeError String
deriving Show
-- | A file that is supposed to exist does not exist
-- (e.g. when we use file scheme to "download" something).
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
-- | File digest verification failed.
data DigestError = DigestError Text Text
deriving Show
-- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int
deriving Show
-- | The 'Location' header was expected during a 3xx redirect, but not found.
data NoLocationHeader = NoLocationHeader
deriving Show
-- | Too many redirects.
data TooManyRedirs = TooManyRedirs
deriving Show
-------------------------
--[ High-level errors ]--
-------------------------
-- | A download failed. The underlying error is encapsulated.
data DownloadFailed = forall es . Show (V es) => DownloadFailed (V es)
deriving instance Show DownloadFailed
-- | A build failed.
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
deriving instance Show BuildFailed
-- | Setting the current GHC version failed.
data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
deriving instance Show GHCupSetError
---------------------------------------------
--[ True Exceptions (e.g. for MonadThrow) ]--
---------------------------------------------
-- | Parsing failed.
data ParseError = ParseError String
deriving Show
instance Exception ParseError
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
data GHCNotFound = GHCNotFound
deriving Show
data BuildConfigNotFound = BuildConfigNotFound (Path Abs)
deriving Show
data DigestError = DigestError Text Text
deriving Show

2
lib/GHCup/Platform.hs
View File

@@ -54,7 +54,7 @@ getArchitecture = case arch of
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts
'[PlatformResultError , DistroNotFound]
'[NoCompatiblePlatform , DistroNotFound]
m
PlatformResult
getPlatform = do

22
lib/GHCup/Types.hs
View File

@@ -43,8 +43,9 @@ data Tag = Latest
deriving (Ord, Eq, Show)
data VersionInfo = VersionInfo
{ _viTags :: [Tag]
, _viArch :: ArchitectureSpec
{ _viTags :: [Tag] -- ^ version specific tag
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
}
deriving (Eq, Show)
@@ -56,17 +57,10 @@ data DownloadInfo = DownloadInfo
deriving (Eq, Show)
data Tool = GHC
| GHCSrc
| Cabal
| GHCup
deriving (Eq, GHC.Generic, Ord, Show)
data ToolRequest = ToolRequest
{ _trTool :: Tool
, _trVersion :: Version
}
deriving (Eq, Show)
data Architecture = A_64
| A_32
deriving (Eq, GHC.Generic, Ord, Show)
@@ -111,17 +105,9 @@ type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
type PlatformSpec = Map Platform PlatformVersionSpec
type ArchitectureSpec = Map Architecture PlatformSpec
type ToolVersionSpec = Map Version VersionInfo
type BinaryDownloads = Map Tool ToolVersionSpec
type SourceDownloads = Map Version DownloadInfo
data GHCupDownloads = GHCupDownloads {
_binaryDownloads :: BinaryDownloads
, _sourceDownloads :: SourceDownloads
} deriving Show
type GHCupDownloads = Map Tool ToolVersionSpec
data URLSource = GHCupURL
| OwnSource URI
| OwnSpec GHCupDownloads
deriving Show

1
lib/GHCup/Types/JSON.hs
View File

@@ -40,7 +40,6 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupDownloads
instance ToJSON URI where

5
lib/GHCup/Types/Optics.hs
View File

@@ -15,11 +15,9 @@ makePrisms ''Platform
makePrisms ''Tag
makeLenses ''PlatformResult
makeLenses ''ToolRequest
makeLenses ''DownloadInfo
makeLenses ''Tag
makeLenses ''VersionInfo
makeLenses ''GHCupDownloads
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
@@ -45,3 +43,6 @@ hostBSL' = lensVL hostBSL
pathL' :: Lens' (URIRef a) ByteString
pathL' = lensVL pathL
queryL' :: Lens' (URIRef a) Query
queryL' = lensVL queryL

92
lib/GHCup/Utils.hs
View File

@@ -43,6 +43,7 @@ import Prelude hiding ( abs
, writeFile
)
import Safe
import System.IO.Error
import System.Posix.FilePath ( takeFileName )
import System.Posix.Files.ByteString ( readSymbolicLink )
import URI.ByteString
@@ -83,6 +84,51 @@ ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
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
-----------------------------------
@@ -90,12 +136,25 @@ ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
-----------------------------------
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
@@ -108,10 +167,8 @@ ghcSet = do
cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir
mc <- executeOut cabalbin [[s|--numeric-version|]] Nothing
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
pure (reportedVer == (verToBS ver))
reportedVer <- cabalSet
pure (reportedVer == ver)
cabalSet :: (MonadIO m, MonadThrow m) => m Version
cabalSet = do
@@ -169,7 +226,7 @@ getGHCForMajor major' minor' = do
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ destination dir
-> Path Abs -- ^ archive path
-> Excepts '[ArchiveError] m ()
-> Excepts '[UnknownArchive] m ()
unpackToDir dest av = do
let fp = E.decodeUtf8 (toFilePath av)
lift $ $(logInfo) [i|Unpacking: #{fp}|]
@@ -198,7 +255,7 @@ unpackToDir dest av = do
-- | Get the tool versions that have this tag.
getTagged :: BinaryDownloads -> Tool -> Tag -> [Version]
getTagged :: GHCupDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
@@ -207,10 +264,10 @@ getTagged av tool tag = toListOf
)
av
getLatest :: BinaryDownloads -> Tool -> Maybe Version
getLatest :: GHCupDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: BinaryDownloads -> Tool -> Maybe Version
getRecommended :: GHCupDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
@@ -241,24 +298,33 @@ 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 $ ToolRequest GHC ver))
(throwE (NotInstalled GHC ver))
files <- liftIO $ getDirsFiles' (ghcdir </> ([rel|bin|] :: Path Rel))
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
(ghcdir </> ([rel|bin/ghc|] :: Path Rel))
)
<$> (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|]

1
lib/GHCup/Utils/Dirs.hs
View File

@@ -76,7 +76,6 @@ withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
--------------
--[ Others ]--
--------------

2
lib/GHCup/Utils/File.hs
View File

@@ -134,7 +134,7 @@ execLogged exe spath args lfile chdir env = do
SPPB.getProcessStatus True True pid >>= \case
i@(Just (SPPB.Exited es)) -> pure $ toProcessError exe args i
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
i -> pure $ toProcessError exe args i

9
lib/GHCup/Utils/Logger.hs
View File

@@ -4,6 +4,7 @@ module GHCup.Utils.Logger where
import GHCup.Utils
import Control.Monad
import Control.Monad.Logger
import HPath
import HPath.IO
@@ -28,15 +29,15 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
mylogger _ _ level str' = do
-- color output
let l = case level of
LevelDebug -> if lcPrintDebug
then toLogStr (style Bold $ color Blue "[ Debug ]")
else mempty
LevelDebug -> toLogStr (style Bold $ color Blue "[ Debug ]")
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
colorOutter out
when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
$ colorOutter out
-- raw output
let lr = case level of

77
lib/GHCup/Utils/Prelude.hs
View File

@@ -1,11 +1,12 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.Utils.Prelude where
@@ -23,6 +24,7 @@ import Data.Versions
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import qualified Data.ByteString.Lazy as L
import qualified Data.Strict.Maybe as S
@@ -136,17 +138,17 @@ fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight
liftException :: ( MonadCatch m
, MonadIO m
, Monad m
, e :< es'
, LiftVariant es es'
)
=> IOErrorType
-> e
-> Excepts es m a
-> Excepts es' m a
liftException errType ex =
liftIOException' :: ( MonadCatch m
, MonadIO m
, Monad m
, e :< es'
, LiftVariant es es'
)
=> IOErrorType
-> e
-> Excepts es m a
-> Excepts es' m a
liftIOException' errType ex =
handleIO
(\e ->
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
@@ -154,6 +156,19 @@ liftException errType ex =
. liftE
liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')
=> IOErrorType
-> e
-> m a
-> Excepts es' m a
liftIOException errType ex =
handleIO
(\e ->
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
)
. lift
hideErrorDef :: IOErrorType -> a -> IO a -> IO a
hideErrorDef err def =
handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e)
@@ -174,6 +189,7 @@ hideExcept :: forall e es es' a m
hideExcept _ a action =
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
hideExcept' :: forall e es es' m
. (Monad m, e :< es, LiftVariant (Remove e es) es')
=> e
@@ -183,6 +199,23 @@ hideExcept' _ action =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
reThrowAll :: forall e es es' a m
. (Monad m, e :< es')
=> (V es -> e)
-> Excepts es m a
-> Excepts es' m a
reThrowAll f = catchAllE (throwE . f)
reThrowAllIO :: forall e es es' a m
. (MonadCatch m, Monad m, MonadIO m, e :< es')
=> (V es -> e)
-> (IOException -> e)
-> Excepts es m a
-> Excepts es' m a
reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither a = case a of
Left e -> throwM e
@@ -200,3 +233,11 @@ intToText = TL.toStrict . B.toLazyText . B.decimal
removeLensFieldLabel :: String -> String
removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
addToCurrentEnv :: MonadIO m
=> [(ByteString, ByteString)]
-> m [(ByteString, ByteString)]
addToCurrentEnv adds = do
cEnv <- liftIO $ getEnvironment
pure (adds ++ cEnv)