Jo
This commit is contained in:
parent
b2a7da29cf
commit
18f891f261
17
TODO.md
17
TODO.md
@ -2,22 +2,29 @@
|
||||
|
||||
## Now
|
||||
|
||||
* static builds and host ghcup (and fix BinaryDownloads)
|
||||
* interoperability with old ghcup
|
||||
* print-system-reqs
|
||||
|
||||
* sign the JSON? (Or check gpg keys?)
|
||||
* set proper ghcup URL
|
||||
|
||||
## Cleanups
|
||||
|
||||
* avoid alternative for IO
|
||||
* don't use Excepts?
|
||||
|
||||
## Maybe
|
||||
|
||||
* maybe: download progress
|
||||
* maybe: changelog Show the changelog of a GHC release (online)
|
||||
* maybe: print-system-reqs Print an approximation of system requirements
|
||||
* OS faking
|
||||
* sign the JSON? (Or check gpg keys?)
|
||||
|
||||
* testing (especially distro detection -> unit tests)
|
||||
|
||||
* hard cleanup command?
|
||||
|
||||
## Later
|
||||
|
||||
* static builds and host ghcup
|
||||
* do bootstrap-haskell with new ghcup
|
||||
* add support for RC/alpha/HEAD versions
|
||||
* check for updates on start
|
||||
* use plucky or oops instead of Excepts
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,26 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module SourceDownloads where
|
||||
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Utils.Version.QQ
|
||||
|
||||
import HPath
|
||||
import URI.ByteString.QQ
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
||||
|
||||
-- TODO: source tarballs
|
||||
-- TODO: reference tarballs
|
||||
sourceDownloads :: SourceDownloads
|
||||
sourceDownloads = M.fromList
|
||||
[ ( [vver|8.6.5|]
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-src.tar.xz|]
|
||||
(Just ([rel|ghc-8.6.5|] :: Path Rel))
|
||||
[s|b47726aaf302eb87b4970fcee924d45d|]
|
||||
)
|
||||
]
|
||||
@ -7,7 +7,6 @@ module Validate where
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.Logger
|
||||
|
||||
import Control.Exception.Safe
|
||||
@ -48,22 +47,22 @@ addError = do
|
||||
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
|
||||
=> GHCupDownloads
|
||||
-> m ExitCode
|
||||
validate dls@GHCupDownloads {..} = do
|
||||
validate dls = do
|
||||
ref <- liftIO $ newIORef 0
|
||||
|
||||
-- * verify binary downloads * --
|
||||
flip runReaderT ref $ do
|
||||
-- unique tags
|
||||
forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkUniqueTags t
|
||||
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
|
||||
|
||||
-- required platforms
|
||||
forM_ (M.toList _binaryDownloads) $ \(t, versions) ->
|
||||
forM_ (M.toList dls) $ \(t, versions) ->
|
||||
forM_ (M.toList versions) $ \(v, vi) ->
|
||||
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
|
||||
checkHasRequiredPlatforms t v arch (M.keys pspecs)
|
||||
|
||||
checkGHCisSemver
|
||||
forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkMandatoryTags t
|
||||
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
|
||||
|
||||
-- exit
|
||||
e <- liftIO $ readIORef ref
|
||||
@ -86,7 +85,7 @@ validate dls@GHCupDownloads {..} = do
|
||||
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
|
||||
|
||||
checkUniqueTags tool = do
|
||||
let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool
|
||||
let allTags = join $ fmap snd $ availableToolVersions dls tool
|
||||
let nonUnique =
|
||||
fmap fst
|
||||
. filter (\(_, b) -> not b)
|
||||
@ -110,7 +109,7 @@ validate dls@GHCupDownloads {..} = do
|
||||
isUniqueTag Recommended = True
|
||||
|
||||
checkGHCisSemver = do
|
||||
let ghcVers = toListOf (binaryDownloads % ix GHC % to M.keys % folded) dls
|
||||
let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
|
||||
forM_ ghcVers $ \v -> case semver (prettyVer v) of
|
||||
Left _ -> do
|
||||
lift $ $(logError) [i|GHC version #{v} is not valid semver|]
|
||||
@ -119,7 +118,7 @@ validate dls@GHCupDownloads {..} = do
|
||||
|
||||
-- a tool must have at least one of each mandatory tags
|
||||
checkMandatoryTags tool = do
|
||||
let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool
|
||||
let allTags = join $ fmap snd $ availableToolVersions dls tool
|
||||
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
|
||||
False -> do
|
||||
lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
|
||||
@ -132,20 +131,25 @@ validateTarballs :: ( Monad m
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> m ExitCode
|
||||
validateTarballs GHCupDownloads {..} = do
|
||||
validateTarballs dls = do
|
||||
ref <- liftIO $ newIORef 0
|
||||
|
||||
flip runReaderT ref $ do
|
||||
-- download/verify all tarballs
|
||||
-- download/verify all binary tarballs
|
||||
let
|
||||
dlis = nub $ join $ (M.elems _binaryDownloads) <&> \versions ->
|
||||
dlbis = nub $ join $ (M.elems dls) <&> \versions ->
|
||||
join $ (M.elems versions) <&> \vi ->
|
||||
join $ (M.elems $ _viArch vi) <&> \pspecs ->
|
||||
join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
|
||||
forM_ dlis $ downloadAll
|
||||
forM_ dlbis $ downloadAll
|
||||
|
||||
let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
|
||||
join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
|
||||
forM_ dlsrc $ downloadAll
|
||||
|
||||
-- exit
|
||||
e <- liftIO $ readIORef ref
|
||||
|
||||
@ -13,10 +13,10 @@ import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Version
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
@ -43,6 +43,7 @@ import URI.ByteString
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
|
||||
|
||||
@ -66,8 +67,9 @@ data Command
|
||||
| List ListOptions
|
||||
| Rm RmOptions
|
||||
| DInfo
|
||||
| Compile CompileOptions
|
||||
| Compile CompileCommand
|
||||
| Upgrade UpgradeOpts
|
||||
| NumericVersion
|
||||
|
||||
data ToolVersion = ToolVersion Version
|
||||
| ToolTag Tag
|
||||
@ -94,8 +96,12 @@ data RmOptions = RmOptions
|
||||
}
|
||||
|
||||
|
||||
data CompileCommand = CompileGHC CompileOptions
|
||||
| CompileCabal CompileOptions
|
||||
|
||||
|
||||
data CompileOptions = CompileOptions
|
||||
{ ghcVer :: Version
|
||||
{ targetVer :: Version
|
||||
, bootstrapVer :: Version
|
||||
, jobs :: Maybe Int
|
||||
, buildConfig :: Maybe (Path Abs)
|
||||
@ -122,21 +128,20 @@ opts =
|
||||
(option
|
||||
(eitherReader parseUri)
|
||||
(short 's' <> long "url-source" <> metavar "URL" <> help
|
||||
"Alternative ghcup download info url"
|
||||
"Alternative ghcup download info url" <> internal
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
( short 'n'
|
||||
<> long "no-verify"
|
||||
<> help
|
||||
"Skip tarball checksum checks (default: False)"
|
||||
(short 'n' <> long "no-verify" <> help
|
||||
"Skip tarball checksum verification (default: False)"
|
||||
)
|
||||
<*> com
|
||||
where
|
||||
parseUri s' =
|
||||
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
|
||||
|
||||
|
||||
com :: Parser Command
|
||||
com =
|
||||
subparser
|
||||
@ -162,6 +167,13 @@ com =
|
||||
(progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"compile"
|
||||
( Compile
|
||||
<$> (info (compileP <**> helper)
|
||||
(progDesc "Compile a tool from source")
|
||||
)
|
||||
)
|
||||
<> commandGroup "Main commands:"
|
||||
)
|
||||
<|> subparser
|
||||
@ -180,13 +192,6 @@ com =
|
||||
(progDesc "Remove a GHC version installed by ghcup")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"compile"
|
||||
( Compile
|
||||
<$> (info (compileOpts <**> helper)
|
||||
(progDesc "Compile GHC from source")
|
||||
)
|
||||
)
|
||||
<> commandGroup "GHC commands:"
|
||||
<> hidden
|
||||
)
|
||||
@ -194,6 +199,11 @@ com =
|
||||
( command
|
||||
"debug-info"
|
||||
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
|
||||
<> command
|
||||
"numeric-version"
|
||||
( (\_ -> NumericVersion)
|
||||
<$> (info (helper) (progDesc "Show the numeric version"))
|
||||
)
|
||||
<> commandGroup "Other commands:"
|
||||
<> hidden
|
||||
)
|
||||
@ -246,6 +256,24 @@ rmOpts :: Parser RmOptions
|
||||
rmOpts = RmOptions <$> versionParser
|
||||
|
||||
|
||||
compileP :: Parser CompileCommand
|
||||
compileP = subparser
|
||||
( command
|
||||
"ghc"
|
||||
( CompileGHC
|
||||
<$> (info (compileOpts <**> helper) (progDesc "Compile GHC from source")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"cabal"
|
||||
( CompileCabal
|
||||
<$> (info (compileOpts <**> helper)
|
||||
(progDesc "Compile Cabal from source")
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
compileOpts :: Parser CompileOptions
|
||||
compileOpts =
|
||||
CompileOptions
|
||||
@ -254,7 +282,7 @@ compileOpts =
|
||||
(bimap (const "Not a valid version") id . version . T.pack)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The GHC version to compile"
|
||||
"The tool version to compile"
|
||||
)
|
||||
)
|
||||
<*> (option
|
||||
@ -386,19 +414,19 @@ main = do
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
, ArchiveError
|
||||
, UnknownArchive
|
||||
, DistroNotFound
|
||||
, FileDoesNotExistError
|
||||
, FileError
|
||||
, CopyError
|
||||
, JSONError
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, PlatformResultError
|
||||
, ProcessError
|
||||
, NoCompatiblePlatform
|
||||
, BuildFailed
|
||||
, TagNotFound
|
||||
, URLException
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
]
|
||||
|
||||
let runSetGHC =
|
||||
@ -408,15 +436,15 @@ main = do
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
, TagNotFound
|
||||
, URLException
|
||||
, JSONError
|
||||
, TagNotFound
|
||||
, DownloadFailed
|
||||
]
|
||||
|
||||
let runListGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[FileDoesNotExistError , URLException , JSONError]
|
||||
. runE @'[FileDoesNotExistError , JSONError , DownloadFailed]
|
||||
|
||||
let runRmGHC =
|
||||
runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
||||
@ -425,7 +453,7 @@ main = do
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[PlatformResultError , NoCompatibleArch , DistroNotFound]
|
||||
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
|
||||
|
||||
let runCompileGHC =
|
||||
runLogger
|
||||
@ -433,31 +461,43 @@ main = do
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
, NotInstalled
|
||||
, GHCNotFound
|
||||
, ArchiveError
|
||||
, ProcessError
|
||||
, URLException
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, BuildConfigNotFound
|
||||
, FileDoesNotExistError
|
||||
, URLException
|
||||
, DownloadFailed
|
||||
, GHCupSetError
|
||||
, NoDownload
|
||||
, UnknownArchive
|
||||
--
|
||||
, JSONError
|
||||
]
|
||||
|
||||
let runCompileCabal =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ JSONError
|
||||
, UnknownArchive
|
||||
, NoDownload
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, BuildFailed
|
||||
]
|
||||
|
||||
let runUpgrade =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ DigestError
|
||||
, URLException
|
||||
, DistroNotFound
|
||||
, PlatformResultError
|
||||
, NoCompatiblePlatform
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, FileDoesNotExistError
|
||||
, JSONError
|
||||
, DownloadFailed
|
||||
, CopyError
|
||||
]
|
||||
|
||||
|
||||
@ -465,16 +505,22 @@ main = do
|
||||
Install (InstallGHC InstallOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
dls <- _binaryDownloads <$> liftE getDownloads
|
||||
dls <- liftE getDownloads
|
||||
v <- liftE $ fromVersion dls instVer GHC
|
||||
liftE $ installTool dls (ToolRequest GHC v) Nothing
|
||||
liftE $ installGHCBin dls v Nothing
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
$ $(logInfo) ([s|GHC installation successful|])
|
||||
VLeft (V (AlreadyInstalled treq)) ->
|
||||
VLeft (V (AlreadyInstalled _ v)) ->
|
||||
runLogger $ $(logWarn)
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
[i|GHC ver #{prettyVer v} already installed|]
|
||||
VLeft (V (BuildFailed tmpdir e)) ->
|
||||
runLogger
|
||||
($(logError) [i|Build failed with #{e}
|
||||
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
|
||||
)
|
||||
>> exitFailure
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
$(logError) [i|#{e}|]
|
||||
@ -483,16 +529,16 @@ main = do
|
||||
Install (InstallCabal InstallOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
dls <- _binaryDownloads <$> liftE getDownloads
|
||||
dls <- liftE getDownloads
|
||||
v <- liftE $ fromVersion dls instVer Cabal
|
||||
liftE $ installTool dls (ToolRequest Cabal v) Nothing
|
||||
liftE $ installCabalBin dls v Nothing
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
$ $(logInfo) ([s|Cabal installation successful|])
|
||||
VLeft (V (AlreadyInstalled treq)) ->
|
||||
VLeft (V (AlreadyInstalled _ v)) ->
|
||||
runLogger $ $(logWarn)
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
[i|Cabal ver #{prettyVer v} already installed|]
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
$(logError) [i|#{e}|]
|
||||
@ -502,7 +548,7 @@ main = do
|
||||
SetGHC (SetGHCOptions {..}) ->
|
||||
void
|
||||
$ (runSetGHC $ do
|
||||
dls <- _binaryDownloads <$> liftE getDownloads
|
||||
dls <- liftE getDownloads
|
||||
v <- liftE $ fromVersion dls ghcVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
@ -515,7 +561,7 @@ main = do
|
||||
List (ListOptions {..}) ->
|
||||
void
|
||||
$ (runListGHC $ do
|
||||
dls <- _binaryDownloads <$> liftE getDownloads
|
||||
dls <- liftE getDownloads
|
||||
liftIO $ listVersions dls lTool lCriteria
|
||||
)
|
||||
>>= \case
|
||||
@ -543,24 +589,52 @@ main = do
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
Compile (CompileOptions {..}) ->
|
||||
Compile (CompileGHC CompileOptions {..}) ->
|
||||
void
|
||||
$ (runCompileGHC $ do
|
||||
dls <- _sourceDownloads <$> liftE getDownloads
|
||||
liftE $ compileGHC dls ghcVer bootstrapVer jobs buildConfig
|
||||
dls <- liftE getDownloads
|
||||
liftE
|
||||
$ compileGHC dls targetVer bootstrapVer jobs buildConfig
|
||||
)
|
||||
>>= \case
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo)
|
||||
([s|GHC successfully compiled and installed|])
|
||||
VLeft (V (AlreadyInstalled treq)) ->
|
||||
VLeft (V (AlreadyInstalled _ v)) ->
|
||||
runLogger $ $(logWarn)
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
[i|GHC ver #{prettyVer v} already installed|]
|
||||
VLeft (V (BuildFailed tmpdir e)) ->
|
||||
runLogger
|
||||
($(logError) [i|Build failed with #{e}
|
||||
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
|
||||
)
|
||||
>> exitFailure
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
Compile (CompileCabal CompileOptions {..}) ->
|
||||
void
|
||||
$ (runCompileCabal $ do
|
||||
dls <- liftE getDownloads
|
||||
liftE $ compileCabal dls
|
||||
targetVer
|
||||
bootstrapVer
|
||||
jobs
|
||||
)
|
||||
>>= \case
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo)
|
||||
([s|Cabal successfully compiled and installed|])
|
||||
VLeft (V (BuildFailed tmpdir e)) ->
|
||||
runLogger
|
||||
($(logError) [i|Build failed with #{e}
|
||||
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
|
||||
)
|
||||
>> exitFailure
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
Upgrade (uOpts) -> do
|
||||
liftIO $ putStrLn $ show uOpts
|
||||
target <- case uOpts of
|
||||
UpgradeInplace -> do
|
||||
efp <- liftIO $ getExecutablePath
|
||||
@ -573,7 +647,7 @@ main = do
|
||||
|
||||
void
|
||||
$ (runUpgrade $ do
|
||||
dls <- _binaryDownloads <$> liftE getDownloads
|
||||
dls <- liftE getDownloads
|
||||
liftE $ upgradeGHCup dls target
|
||||
)
|
||||
>>= \case
|
||||
@ -585,11 +659,12 @@ main = do
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
NumericVersion -> T.hPutStr stdout (prettyPVP ghcUpVer)
|
||||
pure ()
|
||||
|
||||
|
||||
fromVersion :: Monad m
|
||||
=> BinaryDownloads
|
||||
=> GHCupDownloads
|
||||
-> Maybe ToolVersion
|
||||
-> Tool
|
||||
-> Excepts '[TagNotFound] m Version
|
||||
@ -611,6 +686,7 @@ printListResult lr = do
|
||||
, column expand left def def
|
||||
, column expand left def def
|
||||
, column expand left def def
|
||||
, column expand left def def
|
||||
]
|
||||
$ fmap
|
||||
(\ListResult {..} ->
|
||||
@ -621,6 +697,7 @@ printListResult lr = do
|
||||
, fmap toLower . show $ lTool
|
||||
, T.unpack . prettyVer $ lVer
|
||||
, intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag)
|
||||
, if fromSrc then (color Blue "compiled") else mempty
|
||||
]
|
||||
)
|
||||
lr
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
constraints: any.Cabal ==2.4.0.1,
|
||||
any.HUnit ==1.6.0.0,
|
||||
any.HsOpenSSL ==0.11.4.17,
|
||||
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -old-locale,
|
||||
any.IfElse ==0.85,
|
||||
@ -10,22 +9,28 @@ constraints: any.Cabal ==2.4.0.1,
|
||||
abstract-deque -usecas,
|
||||
any.aeson ==1.4.6.0,
|
||||
aeson -bytestring-builder -cffi -developer -fast,
|
||||
any.aeson-pretty ==0.8.8,
|
||||
aeson-pretty -lib-only,
|
||||
any.ansi-terminal ==0.10.3,
|
||||
ansi-terminal -example,
|
||||
any.ansi-wl-pprint ==0.6.9,
|
||||
ansi-wl-pprint -example,
|
||||
any.array ==0.5.3.0,
|
||||
any.ascii-string ==1.0.1.4,
|
||||
any.assoc ==1.0.1,
|
||||
any.async ==2.2.2,
|
||||
async -bench,
|
||||
any.atomic-primops ==0.8.3,
|
||||
atomic-primops -debug,
|
||||
any.attoparsec ==0.13.2.3,
|
||||
attoparsec -developer,
|
||||
any.auto-update ==0.1.6,
|
||||
any.base ==4.12.0.0,
|
||||
any.base-compat ==0.11.1,
|
||||
any.base-orphans ==0.8.2,
|
||||
any.base-prelude ==1.3,
|
||||
any.base16-bytestring ==0.1.1.6,
|
||||
any.base64-bytestring ==1.0.0.3,
|
||||
any.basement ==0.0.11,
|
||||
any.bifunctors ==5.5.7,
|
||||
bifunctors +semigroups +tagged,
|
||||
any.binary ==0.8.6.0,
|
||||
@ -99,6 +104,7 @@ constraints: any.Cabal ==2.4.0.1,
|
||||
any.io-streams ==1.5.1.0,
|
||||
io-streams -nointeractivetests,
|
||||
any.language-bash ==0.9.0,
|
||||
any.lifted-base ==0.2.3.12,
|
||||
any.list-t ==1.0.4,
|
||||
any.lockfree-queue ==0.2.3.1,
|
||||
any.lzma ==0.0.0.3,
|
||||
@ -108,29 +114,42 @@ constraints: any.Cabal ==2.4.0.1,
|
||||
megaparsec -dev,
|
||||
any.mmorph ==1.1.3,
|
||||
any.monad-control ==1.0.2.3,
|
||||
any.monad-logger ==0.3.32,
|
||||
monad-logger +template_haskell,
|
||||
any.monad-loops ==0.4.3,
|
||||
monad-loops +base4,
|
||||
any.mono-traversable ==1.0.15.1,
|
||||
any.mtl ==2.2.2,
|
||||
any.mwc-random ==0.14.0.0,
|
||||
any.network ==3.0.1.1,
|
||||
any.network-uri ==2.6.2.0,
|
||||
any.network-uri ==2.6.3.0,
|
||||
any.old-locale ==1.0.0.7,
|
||||
any.old-time ==1.1.0.3,
|
||||
any.openssl-streams ==1.2.2.0,
|
||||
any.optics ==0.2,
|
||||
any.optics-core ==0.2,
|
||||
any.optics-extra ==0.2,
|
||||
any.optics-th ==0.2,
|
||||
any.optics-vl ==0.2,
|
||||
any.optparse-applicative ==0.15.1.0,
|
||||
any.parsec ==3.1.13.0,
|
||||
any.parser-combinators ==1.2.1,
|
||||
parser-combinators -dev,
|
||||
any.pretty ==1.1.3.6,
|
||||
any.pretty-terminal ==0.1.0.0,
|
||||
any.prettyprinter ==1.6.1,
|
||||
prettyprinter -buildreadme,
|
||||
any.primitive ==0.7.0.0,
|
||||
any.primitive ==0.7.0.1,
|
||||
any.primitive-extras ==0.8,
|
||||
any.primitive-unlifted ==0.1.3.0,
|
||||
any.process ==1.6.5.0,
|
||||
any.profunctors ==5.5.2,
|
||||
any.quickcheck-io ==0.2.0,
|
||||
any.random ==1.1,
|
||||
any.recursion-schemes ==5.1.3,
|
||||
recursion-schemes +template-haskell,
|
||||
any.resourcet ==1.2.3,
|
||||
any.rts ==1.0,
|
||||
any.safe ==0.3.18,
|
||||
any.safe-exceptions ==0.1.7.0,
|
||||
any.scientific ==0.3.6.2,
|
||||
scientific -bytestring-builder -integer-simple,
|
||||
@ -138,26 +157,41 @@ constraints: any.Cabal ==2.4.0.1,
|
||||
semigroupoids +comonad +containers +contravariant +distributive +doctests +tagged +unordered-containers,
|
||||
any.semigroups ==0.19.1,
|
||||
semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,
|
||||
any.setenv ==0.1.1.3,
|
||||
any.sop-core ==0.5.0.0,
|
||||
any.splitmix ==0.0.3,
|
||||
any.split ==0.2.3.4,
|
||||
any.splitmix ==0.0.4,
|
||||
splitmix -optimised-mixer +random,
|
||||
any.stm ==2.5.0.0,
|
||||
any.stm-chans ==3.0.0.4,
|
||||
any.streaming-commons ==0.2.1.2,
|
||||
streaming-commons -use-bytestring-builder,
|
||||
any.streamly ==0.7.1,
|
||||
streamly -debug -dev -examples -examples-sdl -fusion-plugin -has-llvm -inspection -no-charts -no-fusion -streamk,
|
||||
any.streamly-bytestring ==0.1.2,
|
||||
any.streamly-posix ==0.1.0.0,
|
||||
any.strict-base ==0.4.0.0,
|
||||
any.string-interpolate ==0.2.0.0,
|
||||
any.syb ==0.7.1,
|
||||
any.table-layout ==0.8.0.5,
|
||||
any.tagged ==0.8.6,
|
||||
tagged +deepseq +transformers,
|
||||
any.tar-bytestring ==0.6.2.0,
|
||||
any.tar-bytestring ==0.6.3.0,
|
||||
any.template-haskell ==2.14.0.0,
|
||||
any.terminfo ==0.4.1.2,
|
||||
any.terminal-progress-bar ==0.4.1,
|
||||
any.terminal-size ==0.3.2.1,
|
||||
any.text ==1.2.3.1,
|
||||
any.text-conversions ==0.3.0,
|
||||
any.text-icu ==0.7.0.1,
|
||||
any.text-short ==0.1.3,
|
||||
text-short -asserts,
|
||||
any.tf-random ==0.5,
|
||||
any.th-abstraction ==0.3.2.0,
|
||||
any.th-expand-syns ==0.4.5.0,
|
||||
any.th-lift ==0.8.1,
|
||||
any.th-lift-instances ==0.1.14,
|
||||
any.th-orphans ==0.13.9,
|
||||
any.th-reify-many ==0.1.9,
|
||||
any.these ==1.0.1,
|
||||
these +aeson +assoc +quickcheck +semigroupoids,
|
||||
any.time ==1.8.0.2,
|
||||
any.time-compat ==1.9.2.2,
|
||||
time-compat -old-locale,
|
||||
@ -169,14 +203,20 @@ constraints: any.Cabal ==2.4.0.1,
|
||||
any.typed-process ==0.2.6.0,
|
||||
any.unix ==2.7.2.2,
|
||||
any.unix-bytestring ==0.3.7.3,
|
||||
any.unliftio-core ==0.1.2.0,
|
||||
any.unix-compat ==0.5.2,
|
||||
unix-compat -old-time,
|
||||
any.unix-time ==0.4.7,
|
||||
any.unliftio-core ==0.2.0.1,
|
||||
any.unordered-containers ==0.2.10.0,
|
||||
unordered-containers -debug,
|
||||
any.url ==2.1.3,
|
||||
any.uri-bytestring ==0.3.2.2,
|
||||
uri-bytestring -lib-werror,
|
||||
any.utf8-string ==1.0.1.1,
|
||||
any.uuid-types ==1.0.3,
|
||||
any.vector ==0.12.1.2,
|
||||
vector +boundschecks -internalchecks -unsafechecks -wall,
|
||||
any.vector-algorithms ==0.8.0.3,
|
||||
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
|
||||
any.vector-builder ==0.3.8,
|
||||
any.vector-th-unbox ==0.2.1.7,
|
||||
any.versions ==3.5.3,
|
||||
|
||||
12
ghcup.cabal
12
ghcup.cabal
@ -27,6 +27,7 @@ common ascii-string { build-depends: ascii-string >= 1.0 }
|
||||
common async { build-depends: async >= 0.8 }
|
||||
common attoparsec { build-depends: attoparsec >= 0.13 }
|
||||
common base { build-depends: base >= 4.12 && < 5 }
|
||||
common binary { build-depends: binary >= 0.8.6.0 }
|
||||
common bytestring { build-depends: bytestring >= 0.10 }
|
||||
common bzlib { build-depends: bzlib >= 0.5.0.5 }
|
||||
common containers { build-depends: containers >= 0.6 }
|
||||
@ -53,13 +54,14 @@ common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 }
|
||||
common resourcet { build-depends: resourcet >= 1.2.2 }
|
||||
common safe { build-depends: safe >= 0.3.18 }
|
||||
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
|
||||
common streamly { build-depends: streamly >= 0.7 }
|
||||
common streamly { build-depends: streamly >= 0.7.1 }
|
||||
common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 }
|
||||
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
|
||||
common strict-base { build-depends: strict-base >= 0.4 }
|
||||
common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
|
||||
common table-layout { build-depends: table-layout >= 0.8 }
|
||||
common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 }
|
||||
common tar-bytestring { build-depends: tar-bytestring >= 0.6.3.0 }
|
||||
common terminal-progress-bar { build-depends: terminal-progress-bar >= 0.4.1 }
|
||||
common template-haskell { build-depends: template-haskell >= 2.7 }
|
||||
common text { build-depends: text >= 1.2 }
|
||||
common text-icu { build-depends: text-icu >= 0.7 }
|
||||
@ -96,6 +98,7 @@ library
|
||||
, ascii-string
|
||||
, async
|
||||
, attoparsec
|
||||
, binary
|
||||
, bytestring
|
||||
, bzlib
|
||||
, containers
|
||||
@ -128,6 +131,7 @@ library
|
||||
, string-interpolate
|
||||
, tar-bytestring
|
||||
, template-haskell
|
||||
, terminal-progress-bar
|
||||
, text
|
||||
, text-icu
|
||||
, transformers
|
||||
@ -211,9 +215,7 @@ executable ghcup-gen
|
||||
, uri-bytestring
|
||||
, utf8-string
|
||||
main-is: Main.hs
|
||||
other-modules: BinaryDownloads
|
||||
GHCupDownloads
|
||||
SourceDownloads
|
||||
other-modules: GHCupDownloads
|
||||
Validate
|
||||
-- other-extensions:
|
||||
build-depends: ghcup
|
||||
|
||||
569
lib/GHCup.hs
569
lib/GHCup.hs
@ -23,6 +23,7 @@ import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Utils.Version.QQ
|
||||
import GHCup.Version
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
@ -34,7 +35,6 @@ import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
@ -50,7 +50,6 @@ import Prelude hiding ( abs
|
||||
, writeFile
|
||||
)
|
||||
import System.IO.Error
|
||||
import System.Posix.Env.ByteString ( getEnvironment )
|
||||
import System.Posix.FilePath ( getSearchPath )
|
||||
import System.Posix.RawFilePath.Directory.Errors
|
||||
( hideError )
|
||||
@ -65,55 +64,116 @@ import qualified Data.Text.Encoding as E
|
||||
--[ Tool installation ]--
|
||||
-------------------------
|
||||
|
||||
-- TODO: custom logger intepreter and pretty printing
|
||||
|
||||
-- | Install a tool, such as GHC or cabal. This also sets
|
||||
-- the ghc-x.y.z symlinks and potentially the ghc-x.y.
|
||||
--
|
||||
-- This can fail in many ways. You may want to explicitly catch
|
||||
-- `AlreadyInstalled` to not make it fatal.
|
||||
installTool :: ( MonadThrow m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
, MonadResource m
|
||||
) -- tmp file
|
||||
=> BinaryDownloads
|
||||
-> ToolRequest
|
||||
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, ArchiveError
|
||||
, DistroNotFound
|
||||
, FileDoesNotExistError
|
||||
, FileError
|
||||
, JSONError
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, PlatformResultError
|
||||
, ProcessError
|
||||
, URLException
|
||||
, DigestError
|
||||
]
|
||||
m
|
||||
()
|
||||
installTool bDls treq mpfReq = do
|
||||
lift $ $(logDebug) [i|Requested to install: #{treq}|]
|
||||
|
||||
-- stop if GHC is already installed, other tools can be overwritten
|
||||
case treq of
|
||||
(ToolRequest GHC _) ->
|
||||
whenM (liftIO $ toolAlreadyInstalled treq)
|
||||
$ (throwE $ AlreadyInstalled treq)
|
||||
(ToolRequest Cabal _) -> pure ()
|
||||
|
||||
installGHCBin :: ( MonadFail m
|
||||
, MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version
|
||||
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
installGHCBin bDls ver mpfReq = do
|
||||
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
|
||||
whenM (liftIO $ toolAlreadyInstalled GHC ver)
|
||||
$ (throwE $ AlreadyInstalled GHC ver)
|
||||
Settings {..} <- lift ask
|
||||
|
||||
-- download (or use cached version)
|
||||
dlinfo <- liftE $ getDownloadInfo bDls treq mpfReq
|
||||
dlinfo <- liftE $ getDownloadInfo bDls GHC ver mpfReq
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
-- prepare paths
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
|
||||
catchAllE
|
||||
(\es ->
|
||||
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
|
||||
>> throwE (BuildFailed archiveSubdir es)
|
||||
)
|
||||
$ installGHC' archiveSubdir ghcdir
|
||||
|
||||
-- only clean up dir if the build succeeded
|
||||
liftIO $ deleteDirRecursive tmpUnpack
|
||||
|
||||
liftE $ postGHCInstall ver
|
||||
|
||||
where
|
||||
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
|
||||
installGHC' :: (MonadLogger m, MonadIO m)
|
||||
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Excepts '[ProcessError] m ()
|
||||
installGHC' path inst = do
|
||||
lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
|
||||
lEM $ liftIO $ execLogged [s|./configure|]
|
||||
False
|
||||
[[s|--prefix=|] <> toFilePath inst]
|
||||
([rel|ghc-configure.log|] :: Path Rel)
|
||||
(Just path)
|
||||
Nothing
|
||||
lEM $ liftIO $ execLogged [s|make|]
|
||||
True
|
||||
[[s|install|]]
|
||||
([rel|ghc-make.log|] :: Path Rel)
|
||||
(Just path)
|
||||
Nothing
|
||||
pure ()
|
||||
|
||||
|
||||
installCabalBin :: ( MonadMask m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version
|
||||
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
||||
-> Excepts
|
||||
'[ CopyError
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
installCabalBin bDls ver mpfReq = do
|
||||
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
|
||||
Settings {..} <- lift ask
|
||||
|
||||
-- download (or use cached version)
|
||||
dlinfo <- liftE $ getDownloadInfo bDls Cabal ver mpfReq
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
@ -121,62 +181,28 @@ installTool bDls treq mpfReq = do
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
-- prepare paths
|
||||
ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq)
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
|
||||
case treq of
|
||||
(ToolRequest GHC ver) -> do
|
||||
liftE $ installGHC archiveSubdir ghcdir
|
||||
liftE $ postGHCInstall ver
|
||||
(ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir
|
||||
liftE $ installCabal' archiveSubdir bindir
|
||||
pure ()
|
||||
|
||||
|
||||
toolAlreadyInstalled :: ToolRequest -> IO Bool
|
||||
toolAlreadyInstalled ToolRequest {..} = case _trTool of
|
||||
GHC -> ghcInstalled _trVersion
|
||||
Cabal -> cabalInstalled _trVersion
|
||||
|
||||
|
||||
|
||||
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
|
||||
installGHC :: (MonadLogger m, MonadIO m)
|
||||
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Excepts '[ProcessError] m ()
|
||||
installGHC path inst = do
|
||||
lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
|
||||
lEM $ liftIO $ execLogged [s|./configure|]
|
||||
False
|
||||
[[s|--prefix=|] <> toFilePath inst]
|
||||
([rel|ghc-configure.log|] :: Path Rel)
|
||||
(Just path)
|
||||
Nothing
|
||||
lEM $ liftIO $ execLogged [s|make|]
|
||||
True
|
||||
[[s|install|]]
|
||||
([rel|ghc-make.log|] :: Path Rel)
|
||||
(Just path)
|
||||
Nothing
|
||||
pure ()
|
||||
|
||||
|
||||
-- | Install an unpacked cabal distribution.
|
||||
installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Excepts '[FileError] m ()
|
||||
installCabal path inst = do
|
||||
lift $ $(logInfo) [s|Installing cabal|]
|
||||
let cabalFile = [rel|cabal|] :: Path Rel
|
||||
liftIO $ createDirIfMissing newDirPerms inst
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> cabalFile)
|
||||
(inst </> cabalFile)
|
||||
Overwrite
|
||||
where
|
||||
-- | Install an unpacked cabal distribution.
|
||||
installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installCabal' path inst = do
|
||||
lift $ $(logInfo) [s|Installing cabal|]
|
||||
let cabalFile = [rel|cabal|] :: Path Rel
|
||||
liftIO $ createDirIfMissing newDirPerms inst
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> cabalFile)
|
||||
(inst </> cabalFile)
|
||||
Overwrite
|
||||
|
||||
|
||||
|
||||
@ -195,7 +221,7 @@ installCabal path inst = do
|
||||
--
|
||||
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
|
||||
-- for `SetGHCOnly` constructor.
|
||||
setGHC :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> SetGHC
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
@ -207,7 +233,12 @@ setGHC ver sghc = do
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
|
||||
|
||||
when (sghc == SetGHCOnly) $ liftE (delOldSymlinks bindir)
|
||||
-- first delete the old symlinks (this fixes compatibility issues
|
||||
-- with old ghcup)
|
||||
case sghc of
|
||||
SetGHCOnly -> liftE $ rmPlain ver
|
||||
SetGHCMajor -> lift $ rmMajorSymlinks ver
|
||||
SetGHCMinor -> lift $ rmMinorSymlinks ver
|
||||
|
||||
-- for ghc tools (ghc, ghci, haddock, ...)
|
||||
verfiles <- ghcToolFiles ver
|
||||
@ -221,45 +252,39 @@ setGHC ver sghc = do
|
||||
<$> getGHCMajor ver
|
||||
parseRel (toFilePath file <> B.singleton _hyphen <> major')
|
||||
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile
|
||||
(bindir </> targetFile)
|
||||
liftIO $ createSymlink (bindir </> targetFile)
|
||||
(ghcLinkDestination (toFilePath file) ver)
|
||||
|
||||
-- create symlink
|
||||
let fullF = bindir </> targetFile
|
||||
let destL = ghcLinkDestination (toFilePath file) ver
|
||||
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
|
||||
liftIO $ createSymlink fullF destL
|
||||
|
||||
-- create symlink for share dir
|
||||
liftIO $ symlinkShareDir ghcdir verBS
|
||||
lift $ symlinkShareDir ghcdir verBS
|
||||
|
||||
pure ()
|
||||
|
||||
where
|
||||
|
||||
symlinkShareDir :: Path Abs -> ByteString -> IO ()
|
||||
symlinkShareDir :: (MonadIO m, MonadLogger m)
|
||||
=> Path Abs
|
||||
-> ByteString
|
||||
-> m ()
|
||||
symlinkShareDir ghcdir verBS = do
|
||||
destdir <- ghcupBaseDir
|
||||
destdir <- liftIO $ ghcupBaseDir
|
||||
case sghc of
|
||||
SetGHCOnly -> do
|
||||
let sharedir = [rel|share|] :: Path Rel
|
||||
let fullsharedir = ghcdir </> sharedir
|
||||
whenM (doesDirectoryExist fullsharedir) $ do
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile
|
||||
(destdir </> sharedir)
|
||||
createSymlink
|
||||
(destdir </> sharedir)
|
||||
([s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
|
||||
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
|
||||
let fullF = destdir </> sharedir
|
||||
let targetF = [s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir
|
||||
$(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
|
||||
liftIO $ createSymlink fullF targetF
|
||||
_ -> pure ()
|
||||
|
||||
-- The old tool symlinks might be different (e.g. more) than the
|
||||
-- requested version. Have to avoid "stray" symlinks.
|
||||
delOldSymlinks :: forall m
|
||||
. (MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Path Abs
|
||||
-> Excepts '[] m ()
|
||||
delOldSymlinks bindir = catchLiftLeft (\NotInstalled{} -> pure ()) $ do
|
||||
mv <- ghcSet
|
||||
for_ mv $ \ver' -> do
|
||||
verfiles <- ghcToolFiles ver'
|
||||
for_ verfiles $ \f -> liftIO $ deleteFile (bindir </> f)
|
||||
|
||||
|
||||
|
||||
|
||||
@ -278,17 +303,18 @@ data ListResult = ListResult
|
||||
, lTag :: [Tag]
|
||||
, lInstalled :: Bool
|
||||
, lSet :: Bool
|
||||
, fromSrc :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
availableToolVersions :: BinaryDownloads -> Tool -> [(Version, [Tag])]
|
||||
availableToolVersions :: GHCupDownloads -> Tool -> [(Version, [Tag])]
|
||||
availableToolVersions av tool = toListOf
|
||||
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
|
||||
av
|
||||
|
||||
|
||||
listVersions :: BinaryDownloads
|
||||
listVersions :: GHCupDownloads
|
||||
-> Maybe Tool
|
||||
-> Maybe ListCriteria
|
||||
-> IO [ListResult]
|
||||
@ -298,7 +324,8 @@ listVersions av lt criteria = case lt of
|
||||
Nothing -> do
|
||||
ghcvers <- listVersions av (Just GHC) criteria
|
||||
cabalvers <- listVersions av (Just Cabal) criteria
|
||||
pure (ghcvers <> cabalvers)
|
||||
ghcupvers <- listVersions av (Just GHCup) criteria
|
||||
pure (ghcvers <> cabalvers <> ghcupvers)
|
||||
|
||||
where
|
||||
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
|
||||
@ -306,11 +333,17 @@ listVersions av lt criteria = case lt of
|
||||
GHC -> do
|
||||
lSet <- fmap (maybe False (== v)) $ ghcSet
|
||||
lInstalled <- ghcInstalled v
|
||||
fromSrc <- ghcSrcInstalled v
|
||||
pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
|
||||
Cabal -> do
|
||||
lSet <- fmap (== v) $ cabalSet
|
||||
lInstalled <- cabalInstalled v
|
||||
pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
|
||||
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
|
||||
GHCup -> do
|
||||
let lSet = prettyPVP ghcUpVer == prettyVer v
|
||||
let lInstalled = True
|
||||
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
|
||||
|
||||
|
||||
filter' :: [ListResult] -> [ListResult]
|
||||
filter' lr = case criteria of
|
||||
@ -320,8 +353,6 @@ listVersions av lt criteria = case lt of
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ GHC rm ]--
|
||||
--------------
|
||||
@ -335,9 +366,8 @@ rmGHCVer ver = do
|
||||
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
|
||||
dir <- liftIO $ ghcupGHCDir ver
|
||||
let d' = toFilePath dir
|
||||
exists <- liftIO $ doesDirectoryExist dir
|
||||
exists <- liftIO $ doesDirectoryExist dir
|
||||
|
||||
toolsFiles <- liftE $ ghcToolFiles ver
|
||||
|
||||
if exists
|
||||
then do
|
||||
@ -346,59 +376,27 @@ rmGHCVer ver = do
|
||||
liftIO $ deleteDirRecursive dir
|
||||
|
||||
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
|
||||
liftIO $ rmMinorSymlinks
|
||||
lift $ rmMinorSymlinks ver
|
||||
|
||||
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
|
||||
liftE fixMajorSymlinks
|
||||
-- first remove
|
||||
lift $ rmMajorSymlinks ver
|
||||
-- then fix them (e.g. with an earlier version)
|
||||
(mj, mi) <- getGHCMajor ver
|
||||
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
|
||||
|
||||
when isSetGHC $ liftE $ do
|
||||
|
||||
when isSetGHC $ do
|
||||
lift $ $(logInfo) [i|Removing ghc symlinks|]
|
||||
rmPlain toolsFiles
|
||||
liftE $ rmPlain ver
|
||||
|
||||
liftIO
|
||||
$ ghcupBaseDir
|
||||
>>= hideError doesNotExistErrorType
|
||||
. deleteFile
|
||||
. (</> ([rel|share|] :: Path Rel))
|
||||
else throwE (NotInstalled $ ToolRequest GHC ver)
|
||||
else throwE (NotInstalled GHC ver)
|
||||
|
||||
where
|
||||
-- e.g. ghc-8.6.5
|
||||
rmMinorSymlinks :: IO ()
|
||||
rmMinorSymlinks = do
|
||||
bindir <- ghcupBinDir
|
||||
files <- getDirsFiles' bindir
|
||||
let myfiles = filter
|
||||
(\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x)
|
||||
files
|
||||
forM_ myfiles $ \f -> deleteFile (bindir </> f)
|
||||
|
||||
-- E.g. ghc, if this version is the set one.
|
||||
-- This reads `ghcupGHCDir`.
|
||||
rmPlain :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> [Path Rel] -- ^ tools files
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmPlain files = do
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
forM_ files $ \f -> liftIO $ deleteFile (bindir </> f)
|
||||
|
||||
-- e.g. ghc-8.6
|
||||
fixMajorSymlinks :: (MonadFail m, MonadThrow m, MonadIO m)
|
||||
=> Excepts '[NotInstalled] m ()
|
||||
fixMajorSymlinks = do
|
||||
(mj, mi) <- getGHCMajor ver
|
||||
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
|
||||
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
|
||||
-- first delete them
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
let myfiles =
|
||||
filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
|
||||
forM_ myfiles $ \f -> liftIO $ deleteFile (bindir </> f)
|
||||
|
||||
-- then fix them (e.g. with an earlier version)
|
||||
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
|
||||
|
||||
|
||||
|
||||
@ -409,7 +407,7 @@ rmGHCVer ver = do
|
||||
|
||||
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
|
||||
=> Excepts
|
||||
'[PlatformResultError , NoCompatibleArch , DistroNotFound]
|
||||
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
|
||||
m
|
||||
DebugInfo
|
||||
getDebugInfo = do
|
||||
@ -430,38 +428,37 @@ getDebugInfo = do
|
||||
---------------
|
||||
|
||||
|
||||
compileGHC :: ( MonadReader Settings m
|
||||
compileGHC :: ( MonadMask m
|
||||
, MonadReader Settings m
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> SourceDownloads
|
||||
=> GHCupDownloads
|
||||
-> Version -- ^ version to install
|
||||
-> Version -- ^ version to bootstrap with
|
||||
-> Maybe Int -- ^ jobs
|
||||
-> Maybe (Path Abs) -- ^ build config
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, NotInstalled
|
||||
, GHCNotFound
|
||||
, ArchiveError
|
||||
, ProcessError
|
||||
, URLException
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, BuildConfigNotFound
|
||||
, DownloadFailed
|
||||
, GHCupSetError
|
||||
, NoDownload
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
compileGHC dls tver bver jobs mbuildConfig = do
|
||||
let treq = ToolRequest GHC tver
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
|
||||
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
|
||||
when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
|
||||
whenM (liftIO $ toolAlreadyInstalled GHC tver)
|
||||
(throwE $ AlreadyInstalled GHC tver)
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <- preview (ix tver) dls ?? GHCNotFound
|
||||
dlInfo <- preview (ix GHC % ix tver % viSourceDL % _Just) dls ?? NoDownload
|
||||
dl <- liftE $ downloadCached dlInfo Nothing
|
||||
|
||||
-- unpack
|
||||
@ -470,43 +467,20 @@ compileGHC dls tver bver jobs mbuildConfig = do
|
||||
|
||||
bghc <- parseRel ([s|ghc-|] <> verToBS bver)
|
||||
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
||||
|
||||
ghcdir <- liftIO $ ghcupGHCDir tver
|
||||
if
|
||||
| tver >= [vver|8.8.0|] -> do
|
||||
cEnv <- liftIO $ getEnvironment
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
bghcPath <- (liftIO $ searchPath spaths bghc) !? GHCNotFound
|
||||
let newEnv = ([s|GHC|], toFilePath bghcPath) : cEnv
|
||||
lEM $ liftIO $ exec [s|./configure|]
|
||||
False
|
||||
[[s|--prefix=|] <> toFilePath ghcdir]
|
||||
(Just workdir)
|
||||
(Just newEnv)
|
||||
| otherwise -> do
|
||||
lEM $ liftIO $ exec
|
||||
[s|./configure|]
|
||||
False
|
||||
[ [s|--prefix=|] <> toFilePath ghcdir
|
||||
, [s|--with-ghc=|] <> toFilePath bghc
|
||||
]
|
||||
(Just workdir)
|
||||
Nothing
|
||||
|
||||
let build_mk = workdir </> ([rel|mk/build.mk|] :: Path Rel)
|
||||
case mbuildConfig of
|
||||
Just bc -> liftIO $ copyFile bc build_mk Overwrite
|
||||
Nothing -> liftIO $ writeFile build_mk (Just newFilePerms) defaultConf
|
||||
catchAllE
|
||||
(\es ->
|
||||
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
|
||||
>> throwE (BuildFailed workdir es)
|
||||
)
|
||||
$ compile bghc ghcdir workdir
|
||||
markSrcBuilt ghcdir workdir
|
||||
|
||||
lEM $ liftIO $ exec [s|make|]
|
||||
True
|
||||
(maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
|
||||
(Just workdir)
|
||||
Nothing
|
||||
-- only clean up dir if the build succeeded
|
||||
liftIO $ deleteDirRecursive tmpUnpack
|
||||
|
||||
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just workdir) Nothing
|
||||
|
||||
liftE $ postGHCInstall tver
|
||||
reThrowAll GHCupSetError $ postGHCInstall tver
|
||||
pure ()
|
||||
|
||||
where
|
||||
@ -518,28 +492,160 @@ BUILD_SPHINX_PDF = NO
|
||||
HADDOCK_DOCS = YES
|
||||
GhcWithLlvmCodeGen = YES|]
|
||||
|
||||
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
|
||||
=> Path Rel
|
||||
-> Path Abs
|
||||
-> Path Abs
|
||||
-> Excepts
|
||||
'[NoDownload , FileDoesNotExistError , ProcessError]
|
||||
m
|
||||
()
|
||||
compile bghc ghcdir workdir = do
|
||||
lift $ $(logInfo) [i|configuring build|]
|
||||
if
|
||||
| tver >= [vver|8.8.0|] -> do
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
bghcPath <- (liftIO $ searchPath spaths bghc) !? NoDownload
|
||||
newEnv <- addToCurrentEnv [([s|GHC|], toFilePath bghcPath)]
|
||||
lEM $ liftIO $ execLogged [s|./configure|]
|
||||
False
|
||||
[[s|--prefix=|] <> toFilePath ghcdir]
|
||||
([rel|ghc-configure.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
(Just newEnv)
|
||||
| otherwise -> do
|
||||
lEM $ liftIO $ execLogged
|
||||
[s|./configure|]
|
||||
False
|
||||
[ [s|--prefix=|] <> toFilePath ghcdir
|
||||
, [s|--with-ghc=|] <> toFilePath bghc
|
||||
]
|
||||
([rel|ghc-configure.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
Nothing
|
||||
|
||||
case mbuildConfig of
|
||||
Just bc -> liftIOException
|
||||
doesNotExistErrorType
|
||||
(FileDoesNotExistError $ toFilePath bc)
|
||||
(liftIO $ copyFile bc (build_mk workdir) Overwrite)
|
||||
Nothing ->
|
||||
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
|
||||
|
||||
lift
|
||||
$ $(logInfo)
|
||||
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/ghc-make.log' to see the progress.|]
|
||||
lEM $ liftIO $ execLogged [s|make|]
|
||||
True
|
||||
(maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
|
||||
([rel|ghc-make.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
Nothing
|
||||
|
||||
lift $ $(logInfo) [i|Installing...|]
|
||||
lEM $ liftIO $ execLogged [s|make|]
|
||||
True
|
||||
[[s|install|]]
|
||||
([rel|ghc-make.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
Nothing
|
||||
|
||||
markSrcBuilt ghcdir workdir = do
|
||||
let dest = (ghcdir </> ghcUpSrcBuiltFile)
|
||||
liftIO $ copyFile (build_mk workdir) dest Overwrite
|
||||
|
||||
build_mk workdir = workdir </> ([rel|mk/build.mk|] :: Path Rel)
|
||||
|
||||
|
||||
---------------
|
||||
--[ Set GHC ]--
|
||||
---------------
|
||||
compileCabal :: ( MonadReader Settings m
|
||||
, MonadResource m
|
||||
, MonadMask m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version -- ^ version to install
|
||||
-> Version -- ^ GHC version to build with
|
||||
-> Maybe Int
|
||||
-> Excepts
|
||||
'[ BuildFailed
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, NoDownload
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
compileCabal dls tver bver jobs = do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bver}|]
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
|
||||
dl <- liftE $ downloadCached dlInfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
||||
|
||||
reThrowAll (BuildFailed workdir) $ compile workdir
|
||||
|
||||
-- only clean up dir if the build succeeded
|
||||
liftIO $ deleteDirRecursive tmpUnpack
|
||||
|
||||
pure ()
|
||||
|
||||
where
|
||||
compile :: (MonadLogger m, MonadIO m)
|
||||
=> Path Abs
|
||||
-> Excepts '[ProcessError] m ()
|
||||
compile workdir = do
|
||||
lift
|
||||
$ $(logInfo)
|
||||
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/cabal-bootstrap.log' to see the progress.|]
|
||||
|
||||
let v' = verToBS bver
|
||||
cabal_bin <- liftIO $ ghcupBinDir
|
||||
newEnv <- lift $ addToCurrentEnv
|
||||
[ ([s|GHC|] , [s|ghc-|] <> v')
|
||||
, ([s|GHC_PKG|], [s|ghc-pkg-|] <> v')
|
||||
, ([s|GHC_VER|], v')
|
||||
, ([s|PREFIX|] , toFilePath cabal_bin)
|
||||
]
|
||||
|
||||
lEM $ liftIO $ execLogged [s|./bootstrap.sh|]
|
||||
False
|
||||
(maybe [] (\j -> [[s|-j|], fS (show j)]) jobs)
|
||||
([rel|cabal-bootstrap.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
(Just newEnv)
|
||||
|
||||
|
||||
upgradeGHCup :: ( MonadReader Settings m
|
||||
|
||||
|
||||
---------------------
|
||||
--[ Upgrade GHCup ]--
|
||||
---------------------
|
||||
|
||||
|
||||
upgradeGHCup :: ( MonadMask m
|
||||
, MonadReader Settings m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
)
|
||||
=> BinaryDownloads
|
||||
=> GHCupDownloads
|
||||
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
|
||||
-> Excepts
|
||||
'[ DigestError
|
||||
, URLException
|
||||
'[ CopyError
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, PlatformResultError
|
||||
, DownloadFailed
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
]
|
||||
m
|
||||
@ -547,14 +653,16 @@ upgradeGHCup :: ( MonadReader Settings m
|
||||
upgradeGHCup dls mtarget = do
|
||||
lift $ $(logInfo) [i|Upgrading GHCup...|]
|
||||
let latestVer = head $ getTagged dls GHCup Latest
|
||||
dli <- liftE $ getDownloadInfo dls (ToolRequest GHCup latestVer) Nothing
|
||||
dli <- liftE $ getDownloadInfo dls GHCup latestVer Nothing
|
||||
tmp <- lift withGHCupTmpDir
|
||||
let fn = [rel|ghcup|] :: Path Rel
|
||||
p <- liftE $ download dli tmp (Just fn)
|
||||
case mtarget of
|
||||
Nothing -> do
|
||||
dest <- liftIO $ ghcupBinDir
|
||||
liftIO $ copyFile p (dest </> fn) Overwrite
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||
(dest </> fn)
|
||||
Overwrite
|
||||
Just fullDest -> liftIO $ copyFile p fullDest Overwrite
|
||||
pure latestVer
|
||||
|
||||
@ -565,8 +673,9 @@ upgradeGHCup dls mtarget = do
|
||||
-------------
|
||||
|
||||
|
||||
-- | Creates ghc-x.y.z and ghc-x.y symlinks.
|
||||
postGHCInstall :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||
-- | Creates ghc-x.y.z and ghc-x.y symlinks. This is used for
|
||||
-- both installing from source and bindist.
|
||||
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
postGHCInstall ver = do
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -54,7 +54,7 @@ getArchitecture = case arch of
|
||||
|
||||
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
'[PlatformResultError , DistroNotFound]
|
||||
'[NoCompatiblePlatform , DistroNotFound]
|
||||
m
|
||||
PlatformResult
|
||||
getPlatform = do
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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|]
|
||||
|
||||
@ -76,7 +76,6 @@ withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Others ]--
|
||||
--------------
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user