Initial commit
This commit is contained in:
commit
a93aaf9a5f
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
||||
dist-newstyle/
|
||||
5
CHANGELOG.md
Normal file
5
CHANGELOG.md
Normal file
@ -0,0 +1,5 @@
|
||||
# Revision history for ghcup
|
||||
|
||||
## 0.1.0.0 -- YYYY-mm-dd
|
||||
|
||||
* First version. Released on an unsuspecting world.
|
||||
165
LICENSE
Normal file
165
LICENSE
Normal file
@ -0,0 +1,165 @@
|
||||
GNU LESSER GENERAL PUBLIC LICENSE
|
||||
Version 3, 29 June 2007
|
||||
|
||||
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
|
||||
This version of the GNU Lesser General Public License incorporates
|
||||
the terms and conditions of version 3 of the GNU General Public
|
||||
License, supplemented by the additional permissions listed below.
|
||||
|
||||
0. Additional Definitions.
|
||||
|
||||
As used herein, "this License" refers to version 3 of the GNU Lesser
|
||||
General Public License, and the "GNU GPL" refers to version 3 of the GNU
|
||||
General Public License.
|
||||
|
||||
"The Library" refers to a covered work governed by this License,
|
||||
other than an Application or a Combined Work as defined below.
|
||||
|
||||
An "Application" is any work that makes use of an interface provided
|
||||
by the Library, but which is not otherwise based on the Library.
|
||||
Defining a subclass of a class defined by the Library is deemed a mode
|
||||
of using an interface provided by the Library.
|
||||
|
||||
A "Combined Work" is a work produced by combining or linking an
|
||||
Application with the Library. The particular version of the Library
|
||||
with which the Combined Work was made is also called the "Linked
|
||||
Version".
|
||||
|
||||
The "Minimal Corresponding Source" for a Combined Work means the
|
||||
Corresponding Source for the Combined Work, excluding any source code
|
||||
for portions of the Combined Work that, considered in isolation, are
|
||||
based on the Application, and not on the Linked Version.
|
||||
|
||||
The "Corresponding Application Code" for a Combined Work means the
|
||||
object code and/or source code for the Application, including any data
|
||||
and utility programs needed for reproducing the Combined Work from the
|
||||
Application, but excluding the System Libraries of the Combined Work.
|
||||
|
||||
1. Exception to Section 3 of the GNU GPL.
|
||||
|
||||
You may convey a covered work under sections 3 and 4 of this License
|
||||
without being bound by section 3 of the GNU GPL.
|
||||
|
||||
2. Conveying Modified Versions.
|
||||
|
||||
If you modify a copy of the Library, and, in your modifications, a
|
||||
facility refers to a function or data to be supplied by an Application
|
||||
that uses the facility (other than as an argument passed when the
|
||||
facility is invoked), then you may convey a copy of the modified
|
||||
version:
|
||||
|
||||
a) under this License, provided that you make a good faith effort to
|
||||
ensure that, in the event an Application does not supply the
|
||||
function or data, the facility still operates, and performs
|
||||
whatever part of its purpose remains meaningful, or
|
||||
|
||||
b) under the GNU GPL, with none of the additional permissions of
|
||||
this License applicable to that copy.
|
||||
|
||||
3. Object Code Incorporating Material from Library Header Files.
|
||||
|
||||
The object code form of an Application may incorporate material from
|
||||
a header file that is part of the Library. You may convey such object
|
||||
code under terms of your choice, provided that, if the incorporated
|
||||
material is not limited to numerical parameters, data structure
|
||||
layouts and accessors, or small macros, inline functions and templates
|
||||
(ten or fewer lines in length), you do both of the following:
|
||||
|
||||
a) Give prominent notice with each copy of the object code that the
|
||||
Library is used in it and that the Library and its use are
|
||||
covered by this License.
|
||||
|
||||
b) Accompany the object code with a copy of the GNU GPL and this license
|
||||
document.
|
||||
|
||||
4. Combined Works.
|
||||
|
||||
You may convey a Combined Work under terms of your choice that,
|
||||
taken together, effectively do not restrict modification of the
|
||||
portions of the Library contained in the Combined Work and reverse
|
||||
engineering for debugging such modifications, if you also do each of
|
||||
the following:
|
||||
|
||||
a) Give prominent notice with each copy of the Combined Work that
|
||||
the Library is used in it and that the Library and its use are
|
||||
covered by this License.
|
||||
|
||||
b) Accompany the Combined Work with a copy of the GNU GPL and this license
|
||||
document.
|
||||
|
||||
c) For a Combined Work that displays copyright notices during
|
||||
execution, include the copyright notice for the Library among
|
||||
these notices, as well as a reference directing the user to the
|
||||
copies of the GNU GPL and this license document.
|
||||
|
||||
d) Do one of the following:
|
||||
|
||||
0) Convey the Minimal Corresponding Source under the terms of this
|
||||
License, and the Corresponding Application Code in a form
|
||||
suitable for, and under terms that permit, the user to
|
||||
recombine or relink the Application with a modified version of
|
||||
the Linked Version to produce a modified Combined Work, in the
|
||||
manner specified by section 6 of the GNU GPL for conveying
|
||||
Corresponding Source.
|
||||
|
||||
1) Use a suitable shared library mechanism for linking with the
|
||||
Library. A suitable mechanism is one that (a) uses at run time
|
||||
a copy of the Library already present on the user's computer
|
||||
system, and (b) will operate properly with a modified version
|
||||
of the Library that is interface-compatible with the Linked
|
||||
Version.
|
||||
|
||||
e) Provide Installation Information, but only if you would otherwise
|
||||
be required to provide such information under section 6 of the
|
||||
GNU GPL, and only to the extent that such information is
|
||||
necessary to install and execute a modified version of the
|
||||
Combined Work produced by recombining or relinking the
|
||||
Application with a modified version of the Linked Version. (If
|
||||
you use option 4d0, the Installation Information must accompany
|
||||
the Minimal Corresponding Source and Corresponding Application
|
||||
Code. If you use option 4d1, you must provide the Installation
|
||||
Information in the manner specified by section 6 of the GNU GPL
|
||||
for conveying Corresponding Source.)
|
||||
|
||||
5. Combined Libraries.
|
||||
|
||||
You may place library facilities that are a work based on the
|
||||
Library side by side in a single library together with other library
|
||||
facilities that are not Applications and are not covered by this
|
||||
License, and convey such a combined library under terms of your
|
||||
choice, if you do both of the following:
|
||||
|
||||
a) Accompany the combined library with a copy of the same work based
|
||||
on the Library, uncombined with any other library facilities,
|
||||
conveyed under the terms of this License.
|
||||
|
||||
b) Give prominent notice with the combined library that part of it
|
||||
is a work based on the Library, and explaining where to find the
|
||||
accompanying uncombined form of the same work.
|
||||
|
||||
6. Revised Versions of the GNU Lesser General Public License.
|
||||
|
||||
The Free Software Foundation may publish revised and/or new versions
|
||||
of the GNU Lesser General Public License from time to time. Such new
|
||||
versions will be similar in spirit to the present version, but may
|
||||
differ in detail to address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the
|
||||
Library as you received it specifies that a certain numbered version
|
||||
of the GNU Lesser General Public License "or any later version"
|
||||
applies to it, you have the option of following the terms and
|
||||
conditions either of that published version or of any later version
|
||||
published by the Free Software Foundation. If the Library as you
|
||||
received it does not specify a version number of the GNU Lesser
|
||||
General Public License, you may choose any version of the GNU Lesser
|
||||
General Public License ever published by the Free Software Foundation.
|
||||
|
||||
If the Library as you received it specifies that a proxy can decide
|
||||
whether future versions of the GNU Lesser General Public License shall
|
||||
apply, that proxy's public statement of acceptance of any version is
|
||||
permanent authorization for you to choose that version for the
|
||||
Library.
|
||||
37
README.md
Normal file
37
README.md
Normal file
@ -0,0 +1,37 @@
|
||||
# ghcup
|
||||
|
||||
A rewrite of ghcup in haskell.
|
||||
|
||||
## TODO
|
||||
|
||||
* create static ghcup binaries
|
||||
* adjust url in GHCupDownloads
|
||||
* add print-system-reqs command
|
||||
|
||||
## Motivation
|
||||
|
||||
Maintenance problems:
|
||||
|
||||
* platform incompatibilities regularly causing breaking bugs:
|
||||
* [Mktemp not working properly on macOS](https://gitlab.haskell.org/haskell/ghcup/issues/130)
|
||||
* [ln: illegal option -- T on macOS Catalina](https://gitlab.haskell.org/haskell/ghcup/issues/123)
|
||||
* [Wrong tar flag on darwin](https://gitlab.haskell.org/haskell/ghcup/issues/119))
|
||||
* refactoring being difficult due to POSIX sh
|
||||
|
||||
Benefits of a rewrite:
|
||||
|
||||
* Features such as installing [release candidates](https://gitlab.haskell.org/haskell/ghcup/issues/94) or [HEAD builds](https://gitlab.haskell.org/haskell/ghcup/issues/65) can be more conveniently implemented in a rewrite
|
||||
* Refactoring will be easier
|
||||
* Better tool support (such as linting the downloads file)
|
||||
* saner downloads file format (such as JSON)
|
||||
|
||||
Downsides:
|
||||
|
||||
* building static binaries for all platforms (and possibly causing SSL/DNS problems)
|
||||
* still bootstrapping those binaries via a POSIX sh script
|
||||
|
||||
## Goals
|
||||
|
||||
* Correct low-level code
|
||||
* Good exception handling
|
||||
* Cleaner user interface
|
||||
1693
app/ghcup-gen/GHCupDownloads.hs
Normal file
1693
app/ghcup-gen/GHCupDownloads.hs
Normal file
File diff suppressed because it is too large
Load Diff
164
app/ghcup-gen/Main.hs
Normal file
164
app/ghcup-gen/Main.hs
Normal file
@ -0,0 +1,164 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
|
||||
module Main where
|
||||
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Logger
|
||||
import GHCupDownloads
|
||||
|
||||
import Data.Aeson ( eitherDecode )
|
||||
import Data.Aeson.Encode.Pretty
|
||||
import Data.Semigroup ( (<>) )
|
||||
import Options.Applicative hiding ( style )
|
||||
import System.Console.Pretty
|
||||
import System.Exit
|
||||
import System.IO ( stdout )
|
||||
import Validate
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
|
||||
data Options = Options
|
||||
{ optCommand :: Command
|
||||
}
|
||||
|
||||
data Command = GenJSON GenJSONOpts
|
||||
| ValidateJSON ValidateJSONOpts
|
||||
| ValidateTarballs ValidateJSONOpts
|
||||
|
||||
data Output
|
||||
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
|
||||
| StdOutput
|
||||
|
||||
fileOutput :: Parser Output
|
||||
fileOutput =
|
||||
FileOutput
|
||||
<$> (strOption
|
||||
(long "file" <> short 'f' <> metavar "FILENAME" <> help
|
||||
"Output to a file"
|
||||
)
|
||||
)
|
||||
|
||||
stdOutput :: Parser Output
|
||||
stdOutput = flag'
|
||||
StdOutput
|
||||
(short 'o' <> long "stdout" <> help "Print to stdout (default)")
|
||||
|
||||
outputP :: Parser Output
|
||||
outputP = fileOutput <|> stdOutput
|
||||
|
||||
|
||||
data GenJSONOpts = GenJSONOpts
|
||||
{ output :: Maybe Output
|
||||
}
|
||||
|
||||
genJSONOpts :: Parser GenJSONOpts
|
||||
genJSONOpts = GenJSONOpts <$> optional outputP
|
||||
|
||||
|
||||
data Input
|
||||
= FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
|
||||
| StdInput
|
||||
|
||||
fileInput :: Parser Input
|
||||
fileInput =
|
||||
FileInput
|
||||
<$> (strOption
|
||||
(long "file" <> short 'f' <> metavar "FILENAME" <> help
|
||||
"Input file to validate"
|
||||
)
|
||||
)
|
||||
|
||||
stdInput :: Parser Input
|
||||
stdInput = flag'
|
||||
StdInput
|
||||
(short 'i' <> long "stdin" <> help "Validate from stdin (default)")
|
||||
|
||||
inputP :: Parser Input
|
||||
inputP = fileInput <|> stdInput
|
||||
|
||||
data ValidateJSONOpts = ValidateJSONOpts
|
||||
{ input :: Maybe Input
|
||||
}
|
||||
|
||||
validateJSONOpts :: Parser ValidateJSONOpts
|
||||
validateJSONOpts = ValidateJSONOpts <$> optional inputP
|
||||
|
||||
opts :: Parser Options
|
||||
opts = Options <$> com
|
||||
|
||||
com :: Parser Command
|
||||
com = subparser
|
||||
( (command
|
||||
"gen"
|
||||
( GenJSON
|
||||
<$> (info (genJSONOpts <**> helper)
|
||||
(progDesc "Generate the json downloads file")
|
||||
)
|
||||
)
|
||||
)
|
||||
<> (command
|
||||
"check"
|
||||
( ValidateJSON
|
||||
<$> (info (validateJSONOpts <**> helper)
|
||||
(progDesc "Validate the JSON")
|
||||
)
|
||||
)
|
||||
)
|
||||
<> (command
|
||||
"check-tarballs"
|
||||
( ValidateTarballs
|
||||
<$> (info
|
||||
(validateJSONOpts <**> helper)
|
||||
(progDesc "Validate all tarballs (download and checksum)")
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
||||
>>= \Options {..} -> case optCommand of
|
||||
GenJSON gopts -> do
|
||||
let
|
||||
bs = encodePretty' (defConfig { confIndent = Spaces 2 })
|
||||
ghcupDownloads
|
||||
case gopts of
|
||||
GenJSONOpts { output = Nothing } -> L.hPutStr stdout bs
|
||||
GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
|
||||
GenJSONOpts { output = Just (FileOutput file) } ->
|
||||
L.writeFile file bs
|
||||
ValidateJSON vopts -> case vopts of
|
||||
ValidateJSONOpts { input = Nothing } ->
|
||||
L.getContents >>= valAndExit validate
|
||||
ValidateJSONOpts { input = Just StdInput } ->
|
||||
L.getContents >>= valAndExit validate
|
||||
ValidateJSONOpts { input = Just (FileInput file) } ->
|
||||
L.readFile file >>= valAndExit validate
|
||||
ValidateTarballs vopts -> case vopts of
|
||||
ValidateJSONOpts { input = Nothing } ->
|
||||
L.getContents >>= valAndExit validateTarballs
|
||||
ValidateJSONOpts { input = Just StdInput } ->
|
||||
L.getContents >>= valAndExit validateTarballs
|
||||
ValidateJSONOpts { input = Just (FileInput file) } ->
|
||||
L.readFile file >>= valAndExit validateTarballs
|
||||
pure ()
|
||||
|
||||
where
|
||||
valAndExit f contents = do
|
||||
av <- case eitherDecode contents of
|
||||
Right r -> pure r
|
||||
Left e -> die (color Red $ show e)
|
||||
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
|
||||
>>= exitWith
|
||||
|
||||
181
app/ghcup-gen/Validate.hs
Normal file
181
app/ghcup-gen/Validate.hs
Normal file
@ -0,0 +1,181 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Validate where
|
||||
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Logger
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader.Class
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Reader ( runReaderT )
|
||||
import Control.Monad.Trans.Resource ( runResourceT
|
||||
, MonadUnliftIO
|
||||
)
|
||||
import Data.IORef
|
||||
import Data.List
|
||||
import Data.String.Interpolate
|
||||
import Data.Versions
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import System.Exit
|
||||
import System.IO
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Map.Strict as M
|
||||
|
||||
|
||||
data ValidationError = InternalError String
|
||||
deriving Show
|
||||
|
||||
instance Exception ValidationError
|
||||
|
||||
|
||||
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
|
||||
addError = do
|
||||
ref <- ask
|
||||
liftIO $ modifyIORef ref (+ 1)
|
||||
|
||||
|
||||
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
|
||||
=> GHCupDownloads
|
||||
-> m ExitCode
|
||||
validate dls = do
|
||||
ref <- liftIO $ newIORef 0
|
||||
|
||||
-- * verify binary downloads * --
|
||||
flip runReaderT ref $ do
|
||||
-- unique tags
|
||||
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
|
||||
|
||||
-- required platforms
|
||||
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 dls) $ \(t, _) -> checkMandatoryTags t
|
||||
|
||||
-- exit
|
||||
e <- liftIO $ readIORef ref
|
||||
if e > 0
|
||||
then pure $ ExitFailure e
|
||||
else do
|
||||
lift $ $(logInfo) [i|All good|]
|
||||
pure ExitSuccess
|
||||
where
|
||||
checkHasRequiredPlatforms t v arch pspecs = do
|
||||
let v' = prettyVer v
|
||||
when (not $ any (== Linux UnknownLinux) pspecs) $ do
|
||||
lift $ $(logError)
|
||||
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
|
||||
addError
|
||||
when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
|
||||
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
|
||||
addError
|
||||
when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
|
||||
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
|
||||
|
||||
checkUniqueTags tool = do
|
||||
let allTags = join $ fmap snd $ availableToolVersions dls tool
|
||||
let nonUnique =
|
||||
fmap fst
|
||||
. filter (\(_, b) -> not b)
|
||||
<$> ( mapM
|
||||
(\case
|
||||
[] -> throwM $ InternalError "empty inner list"
|
||||
(t : ts) ->
|
||||
pure $ (t, ) $ if isUniqueTag t then ts == [] else True
|
||||
)
|
||||
. group
|
||||
. sort
|
||||
$ allTags
|
||||
)
|
||||
case join nonUnique of
|
||||
[] -> pure ()
|
||||
xs -> do
|
||||
lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
|
||||
addError
|
||||
where
|
||||
isUniqueTag Latest = True
|
||||
isUniqueTag Recommended = True
|
||||
|
||||
checkGHCisSemver = do
|
||||
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|]
|
||||
addError
|
||||
Right _ -> pure ()
|
||||
|
||||
-- a tool must have at least one of each mandatory tags
|
||||
checkMandatoryTags tool = do
|
||||
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}|]
|
||||
addError
|
||||
True -> pure ()
|
||||
|
||||
|
||||
validateTarballs :: ( Monad m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> m ExitCode
|
||||
validateTarballs dls = do
|
||||
ref <- liftIO $ newIORef 0
|
||||
|
||||
flip runReaderT ref $ do
|
||||
-- download/verify all binary tarballs
|
||||
let
|
||||
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_ dlbis $ downloadAll
|
||||
|
||||
let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
|
||||
join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
|
||||
forM_ dlsrc $ downloadAll
|
||||
|
||||
-- exit
|
||||
e <- liftIO $ readIORef ref
|
||||
if e > 0
|
||||
then pure $ ExitFailure e
|
||||
else do
|
||||
lift $ $(logInfo) [i|All good|]
|
||||
pure ExitSuccess
|
||||
|
||||
where
|
||||
downloadAll dli = do
|
||||
let settings = Settings True GHCupURL False
|
||||
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = (\_ -> pure ())
|
||||
}
|
||||
|
||||
r <-
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runResourceT
|
||||
. runE
|
||||
$ downloadCached dli Nothing
|
||||
case r of
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> do
|
||||
lift $ $(logError)
|
||||
[i|Could not download (or verify hash) of #{dli}, Error was: #{e}|]
|
||||
addError
|
||||
702
app/ghcup/Main.hs
Normal file
702
app/ghcup/Main.hs
Normal file
@ -0,0 +1,702 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
|
||||
module Main where
|
||||
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Version
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Bifunctor
|
||||
import Data.Char
|
||||
import Data.List ( intercalate )
|
||||
import Data.Semigroup ( (<>) )
|
||||
import Data.String.Interpolate
|
||||
import Data.Versions
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Options.Applicative hiding ( style )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Console.Pretty
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.IO hiding ( appendFile )
|
||||
import Text.Read
|
||||
import Text.Layout.Table
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
data Options = Options
|
||||
{
|
||||
-- global options
|
||||
optVerbose :: Bool
|
||||
, optCache :: Bool
|
||||
, optUrlSource :: Maybe URI
|
||||
, optNoVerify :: Bool
|
||||
-- commands
|
||||
, optCommand :: Command
|
||||
}
|
||||
|
||||
data Command
|
||||
= Install InstallCommand
|
||||
| SetGHC SetGHCOptions
|
||||
| List ListOptions
|
||||
| Rm RmOptions
|
||||
| DInfo
|
||||
| Compile CompileCommand
|
||||
| Upgrade UpgradeOpts
|
||||
| NumericVersion
|
||||
|
||||
data ToolVersion = ToolVersion Version
|
||||
| ToolTag Tag
|
||||
|
||||
|
||||
data InstallCommand = InstallGHC InstallOptions
|
||||
| InstallCabal InstallOptions
|
||||
|
||||
data InstallOptions = InstallOptions
|
||||
{ instVer :: Maybe ToolVersion
|
||||
}
|
||||
|
||||
data SetGHCOptions = SetGHCOptions
|
||||
{ ghcVer :: Maybe ToolVersion
|
||||
}
|
||||
|
||||
data ListOptions = ListOptions
|
||||
{ lTool :: Maybe Tool
|
||||
, lCriteria :: Maybe ListCriteria
|
||||
}
|
||||
|
||||
data RmOptions = RmOptions
|
||||
{ ghcVer :: Version
|
||||
}
|
||||
|
||||
|
||||
data CompileCommand = CompileGHC CompileOptions
|
||||
| CompileCabal CompileOptions
|
||||
|
||||
|
||||
data CompileOptions = CompileOptions
|
||||
{ targetVer :: Version
|
||||
, bootstrapVer :: Version
|
||||
, jobs :: Maybe Int
|
||||
, buildConfig :: Maybe (Path Abs)
|
||||
}
|
||||
|
||||
data UpgradeOpts = UpgradeInplace
|
||||
| UpgradeAt (Path Abs)
|
||||
| UpgradeGHCupDir
|
||||
deriving Show
|
||||
|
||||
|
||||
opts :: Parser Options
|
||||
opts =
|
||||
Options
|
||||
<$> switch
|
||||
(short 'v' <> long "verbose" <> help
|
||||
"Whether to enable verbosity (default: False)"
|
||||
)
|
||||
<*> switch
|
||||
(short 'c' <> long "cache" <> help
|
||||
"Whether to cache downloads (default: False)"
|
||||
)
|
||||
<*> (optional
|
||||
(option
|
||||
(eitherReader parseUri)
|
||||
(short 's' <> long "url-source" <> metavar "URL" <> help
|
||||
"Alternative ghcup download info url" <> internal
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> switch
|
||||
(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
|
||||
( command
|
||||
"install"
|
||||
( Install
|
||||
<$> (info (installP <**> helper)
|
||||
(progDesc "Install or update GHC/cabal")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"list"
|
||||
( List
|
||||
<$> (info (listOpts <**> helper)
|
||||
(progDesc "Show available GHCs and other tools")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"upgrade"
|
||||
( Upgrade
|
||||
<$> (info
|
||||
(upgradeOptsP <**> helper)
|
||||
(progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"compile"
|
||||
( Compile
|
||||
<$> (info (compileP <**> helper)
|
||||
(progDesc "Compile a tool from source")
|
||||
)
|
||||
)
|
||||
<> commandGroup "Main commands:"
|
||||
)
|
||||
<|> subparser
|
||||
( command
|
||||
"set"
|
||||
( SetGHC
|
||||
<$> (info (setGHCOpts <**> helper)
|
||||
(progDesc "Set the currently active GHC version")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"rm"
|
||||
( Rm
|
||||
<$> (info
|
||||
(rmOpts <**> helper)
|
||||
(progDesc "Remove a GHC version installed by ghcup")
|
||||
)
|
||||
)
|
||||
<> commandGroup "GHC commands:"
|
||||
<> hidden
|
||||
)
|
||||
<|> subparser
|
||||
( 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
|
||||
)
|
||||
|
||||
|
||||
installP :: Parser InstallCommand
|
||||
installP = subparser
|
||||
( command
|
||||
"ghc"
|
||||
( InstallGHC
|
||||
<$> (info (installOpts <**> helper) (progDesc "Install a GHC version"))
|
||||
)
|
||||
<> command
|
||||
"cabal"
|
||||
( InstallCabal
|
||||
<$> (info (installOpts <**> helper)
|
||||
(progDesc "Install or update a Cabal version")
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
installOpts :: Parser InstallOptions
|
||||
installOpts = InstallOptions <$> optional toolVersionParser
|
||||
|
||||
setGHCOpts :: Parser SetGHCOptions
|
||||
setGHCOpts = SetGHCOptions <$> optional toolVersionParser
|
||||
|
||||
listOpts :: Parser ListOptions
|
||||
listOpts =
|
||||
ListOptions
|
||||
<$> optional
|
||||
(option
|
||||
(eitherReader toolParser)
|
||||
(short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
|
||||
"Tool to list versions for. Default is all"
|
||||
)
|
||||
)
|
||||
<*> (optional
|
||||
(option
|
||||
(eitherReader criteriaParser)
|
||||
( short 'c'
|
||||
<> long "show-criteria"
|
||||
<> metavar "<installed|set>"
|
||||
<> help "Show only installed or set tool versions"
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
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
|
||||
<$> (option
|
||||
(eitherReader
|
||||
(bimap (const "Not a valid version") id . version . T.pack)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The tool version to compile"
|
||||
)
|
||||
)
|
||||
<*> (option
|
||||
(eitherReader
|
||||
(bimap (const "Not a valid version") id . version . T.pack)
|
||||
)
|
||||
( short 'b'
|
||||
<> long "bootstrap-version"
|
||||
<> metavar "BOOTSTRAP_VERSION"
|
||||
<> help "The GHC version to bootstrap with (must be installed)"
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader (readEither @Int))
|
||||
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
|
||||
"How many jobs to use for make"
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
)
|
||||
(short 'c' <> long "config" <> metavar "CONFIG" <> help
|
||||
"Absolute path to build config file"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
versionParser :: Parser Version
|
||||
versionParser = option
|
||||
(eitherReader (bimap (const "Not a valid version") id . version . T.pack))
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
|
||||
)
|
||||
|
||||
|
||||
toolVersionParser :: Parser ToolVersion
|
||||
toolVersionParser = verP <|> toolP
|
||||
where
|
||||
verP = ToolVersion <$> versionParser
|
||||
toolP =
|
||||
ToolTag
|
||||
<$> (option
|
||||
(eitherReader
|
||||
(\s' -> case fmap toLower s' of
|
||||
"recommended" -> Right Recommended
|
||||
"latest" -> Right Latest
|
||||
other -> Left ([i|Unknown tag #{other}|])
|
||||
)
|
||||
)
|
||||
(short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
|
||||
)
|
||||
|
||||
|
||||
toolParser :: String -> Either String Tool
|
||||
toolParser s' | t == T.pack "ghc" = Right GHC
|
||||
| t == T.pack "cabal" = Right Cabal
|
||||
| otherwise = Left ("Unknown tool: " <> s')
|
||||
where t = T.toLower (T.pack s')
|
||||
|
||||
|
||||
criteriaParser :: String -> Either String ListCriteria
|
||||
criteriaParser s' | t == T.pack "installed" = Right ListInstalled
|
||||
| t == T.pack "set" = Right ListSet
|
||||
| otherwise = Left ("Unknown criteria: " <> s')
|
||||
where t = T.toLower (T.pack s')
|
||||
|
||||
|
||||
toSettings :: Options -> Settings
|
||||
toSettings Options {..} =
|
||||
let cache = optCache
|
||||
urlSource = maybe GHCupURL OwnSource optUrlSource
|
||||
noVerify = optNoVerify
|
||||
in Settings { .. }
|
||||
|
||||
|
||||
upgradeOptsP :: Parser UpgradeOpts
|
||||
upgradeOptsP =
|
||||
flag'
|
||||
UpgradeInplace
|
||||
(short 'i' <> long "inplace" <> help
|
||||
"Upgrade ghcup in-place (wherever it's at)"
|
||||
)
|
||||
<|> ( UpgradeAt
|
||||
<$> (option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
)
|
||||
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
|
||||
"Absolute filepath to write ghcup into"
|
||||
)
|
||||
)
|
||||
)
|
||||
<|> (pure UpgradeGHCupDir)
|
||||
|
||||
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
||||
>>= \opt@Options {..} -> do
|
||||
let settings = toSettings opt
|
||||
|
||||
-- logger interpreter
|
||||
logfile <- initGHCupFileLogging ([rel|ghcup.log|] :: Path Rel)
|
||||
let runLogger = myLoggerT LoggerConfig
|
||||
{ lcPrintDebug = optVerbose
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = appendFile logfile
|
||||
}
|
||||
|
||||
-- wrapper to run effects with settings
|
||||
let runInstTool =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
, UnknownArchive
|
||||
, DistroNotFound
|
||||
, FileDoesNotExistError
|
||||
, CopyError
|
||||
, JSONError
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, NoCompatiblePlatform
|
||||
, BuildFailed
|
||||
, TagNotFound
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
]
|
||||
|
||||
let runSetGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
, TagNotFound
|
||||
, JSONError
|
||||
, TagNotFound
|
||||
, DownloadFailed
|
||||
]
|
||||
|
||||
let runListGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[FileDoesNotExistError , JSONError , DownloadFailed]
|
||||
|
||||
let runRmGHC =
|
||||
runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
||||
|
||||
let runDebugInfo =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
|
||||
|
||||
let runCompileGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, 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
|
||||
, DistroNotFound
|
||||
, NoCompatiblePlatform
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, FileDoesNotExistError
|
||||
, JSONError
|
||||
, DownloadFailed
|
||||
, CopyError
|
||||
]
|
||||
|
||||
|
||||
case optCommand of
|
||||
Install (InstallGHC InstallOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
dls <- liftE getDownloads
|
||||
v <- liftE $ fromVersion dls instVer GHC
|
||||
liftE $ installGHCBin dls v Nothing
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
$ $(logInfo) ([s|GHC installation successful|])
|
||||
VLeft (V (AlreadyInstalled _ v)) ->
|
||||
runLogger $ $(logWarn)
|
||||
[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}|]
|
||||
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
|
||||
exitFailure
|
||||
Install (InstallCabal InstallOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
dls <- liftE getDownloads
|
||||
v <- liftE $ fromVersion dls instVer Cabal
|
||||
liftE $ installCabalBin dls v Nothing
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
$ $(logInfo) ([s|Cabal installation successful|])
|
||||
VLeft (V (AlreadyInstalled _ v)) ->
|
||||
runLogger $ $(logWarn)
|
||||
[i|Cabal ver #{prettyVer v} already installed|]
|
||||
VLeft e -> do
|
||||
runLogger $ do
|
||||
$(logError) [i|#{e}|]
|
||||
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
|
||||
exitFailure
|
||||
|
||||
SetGHC (SetGHCOptions {..}) ->
|
||||
void
|
||||
$ (runSetGHC $ do
|
||||
dls <- liftE getDownloads
|
||||
v <- liftE $ fromVersion dls ghcVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo) ([s|GHC successfully set|])
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
List (ListOptions {..}) ->
|
||||
void
|
||||
$ (runListGHC $ do
|
||||
dls <- liftE getDownloads
|
||||
liftIO $ listVersions dls lTool lCriteria
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> liftIO $ printListResult r
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
Rm (RmOptions {..}) ->
|
||||
void
|
||||
$ (runRmGHC $ do
|
||||
liftE $ rmGHCVer ghcVer
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ()
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
DInfo -> do
|
||||
void
|
||||
$ (runDebugInfo $ do
|
||||
liftE $ getDebugInfo
|
||||
)
|
||||
>>= \case
|
||||
VRight dinfo -> putStrLn $ show dinfo
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
Compile (CompileGHC CompileOptions {..}) ->
|
||||
void
|
||||
$ (runCompileGHC $ do
|
||||
dls <- liftE getDownloads
|
||||
liftE
|
||||
$ compileGHC dls targetVer bootstrapVer jobs buildConfig
|
||||
)
|
||||
>>= \case
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo)
|
||||
([s|GHC successfully compiled and installed|])
|
||||
VLeft (V (AlreadyInstalled _ v)) ->
|
||||
runLogger $ $(logWarn)
|
||||
[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
|
||||
target <- case uOpts of
|
||||
UpgradeInplace -> do
|
||||
efp <- liftIO $ getExecutablePath
|
||||
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
|
||||
pure $ Just p
|
||||
(UpgradeAt p) -> pure $ Just p
|
||||
UpgradeGHCupDir -> do
|
||||
bdir <- liftIO $ ghcupBinDir
|
||||
pure (Just (bdir </> ([rel|ghcup|] :: Path Rel)))
|
||||
|
||||
void
|
||||
$ (runUpgrade $ do
|
||||
dls <- liftE getDownloads
|
||||
liftE $ upgradeGHCup dls target
|
||||
)
|
||||
>>= \case
|
||||
VRight v' -> do
|
||||
let pretty_v = prettyVer v'
|
||||
runLogger
|
||||
$ $(logInfo)
|
||||
[i|Successfully upgraded GHCup to version #{pretty_v}|]
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
NumericVersion -> T.hPutStr stdout (prettyPVP ghcUpVer)
|
||||
pure ()
|
||||
|
||||
|
||||
fromVersion :: Monad m
|
||||
=> GHCupDownloads
|
||||
-> Maybe ToolVersion
|
||||
-> Tool
|
||||
-> Excepts '[TagNotFound] m Version
|
||||
fromVersion av Nothing tool =
|
||||
getRecommended av tool ?? TagNotFound Recommended tool
|
||||
fromVersion _ (Just (ToolVersion v)) _ = pure v
|
||||
fromVersion av (Just (ToolTag Latest)) tool =
|
||||
getLatest av tool ?? TagNotFound Latest tool
|
||||
fromVersion av (Just (ToolTag Recommended)) tool =
|
||||
getRecommended av tool ?? TagNotFound Recommended tool
|
||||
|
||||
|
||||
printListResult :: [ListResult] -> IO ()
|
||||
printListResult lr = do
|
||||
let
|
||||
formatted =
|
||||
gridString
|
||||
[ column expand left def def
|
||||
, column expand left def def
|
||||
, column expand left def def
|
||||
, column expand left def def
|
||||
, column expand left def def
|
||||
]
|
||||
$ fmap
|
||||
(\ListResult {..} ->
|
||||
[ if
|
||||
| lSet -> (color Green "✔✔")
|
||||
| lInstalled -> (color Green "✓")
|
||||
| otherwise -> (color Red "✗")
|
||||
, fmap toLower . show $ lTool
|
||||
, T.unpack . prettyVer $ lVer
|
||||
, intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag)
|
||||
, if fromSrc then (color Blue "compiled") else mempty
|
||||
]
|
||||
)
|
||||
lr
|
||||
putStrLn $ formatted
|
||||
15
cabal.project
Normal file
15
cabal.project
Normal file
@ -0,0 +1,15 @@
|
||||
packages: ./ghcup.cabal
|
||||
|
||||
with-compiler: ghc-8.6.5
|
||||
|
||||
optimization: 2
|
||||
|
||||
package streamly
|
||||
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
||||
|
||||
package ghcup
|
||||
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
||||
|
||||
package tar-bytestring
|
||||
ghc-options: -O2
|
||||
|
||||
229
cabal.project.freeze
Normal file
229
cabal.project.freeze
Normal file
@ -0,0 +1,229 @@
|
||||
constraints: any.Cabal ==2.4.0.1,
|
||||
any.HsOpenSSL ==0.11.4.17,
|
||||
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -old-locale,
|
||||
any.IfElse ==0.85,
|
||||
any.QuickCheck ==2.13.2,
|
||||
QuickCheck +templatehaskell,
|
||||
any.StateVar ==1.2,
|
||||
any.abstract-deque ==0.3,
|
||||
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.bifunctors ==5.5.7,
|
||||
bifunctors +semigroups +tagged,
|
||||
any.binary ==0.8.6.0,
|
||||
any.blaze-builder ==0.4.1.0,
|
||||
any.brotli ==0.0.0.0,
|
||||
any.brotli-streams ==0.0.0.0,
|
||||
any.bytestring ==0.10.8.2,
|
||||
any.bytestring-builder ==0.10.8.2.0,
|
||||
bytestring-builder +bytestring_has_builder,
|
||||
any.bzlib ==0.5.0.5,
|
||||
any.cabal-doctest ==1.0.8,
|
||||
any.case-insensitive ==1.2.1.0,
|
||||
any.cereal ==0.5.8.1,
|
||||
cereal -bytestring-builder,
|
||||
any.clock ==0.8,
|
||||
clock -llvm,
|
||||
any.cmdargs ==0.10.20,
|
||||
cmdargs +quotation -testprog,
|
||||
any.colour ==2.3.5,
|
||||
any.comonad ==5.0.6,
|
||||
comonad +containers +distributive +test-doctests,
|
||||
any.conduit ==1.3.1.2,
|
||||
any.conduit-extra ==1.3.4,
|
||||
any.containers ==0.6.0.1,
|
||||
any.contravariant ==1.5.2,
|
||||
contravariant +semigroups +statevar +tagged,
|
||||
any.data-default-class ==0.1.2.0,
|
||||
any.data-default-instances-base ==0.1.0.1,
|
||||
any.deepseq ==1.4.4.0,
|
||||
any.deferred-folds ==0.9.10.1,
|
||||
any.directory ==1.3.3.0 || ==1.3.6.0,
|
||||
any.distributive ==0.6.1,
|
||||
distributive +semigroups +tagged,
|
||||
any.dlist ==0.8.0.7,
|
||||
any.easy-file ==0.2.2,
|
||||
any.errors ==2.3.0,
|
||||
any.exceptions ==0.10.4,
|
||||
exceptions +transformers-0-4,
|
||||
any.extra ==1.7,
|
||||
any.fast-logger ==3.0.1,
|
||||
any.filepath ==1.4.2.1,
|
||||
any.focus ==1.0.1.3,
|
||||
any.foldl ==1.4.6,
|
||||
any.free ==5.1.3,
|
||||
any.fusion-plugin-types ==0.1.0,
|
||||
any.generics-sop ==0.5.0.0,
|
||||
any.ghc-boot-th ==8.6.5,
|
||||
any.ghc-prim ==0.5.3,
|
||||
any.happy ==1.19.12,
|
||||
happy +small_base,
|
||||
any.hashable ==1.3.0.0,
|
||||
hashable -examples +integer-gmp +sse2 -sse41,
|
||||
any.haskell-src-exts ==1.23.0,
|
||||
any.haskell-src-meta ==0.8.5,
|
||||
any.haskus-utils-data ==1.2,
|
||||
any.haskus-utils-types ==1.5,
|
||||
any.haskus-utils-variant ==3.0,
|
||||
any.heaps ==0.3.6.1,
|
||||
any.hopenssl ==2.2.4,
|
||||
hopenssl -link-libz,
|
||||
any.hpath ==0.11.0,
|
||||
any.hpath-directory ==0.13.2,
|
||||
any.hpath-filepath ==0.10.4,
|
||||
any.hpath-io ==0.13.1,
|
||||
any.hpath-posix ==0.13.1,
|
||||
any.hsc2hs ==0.68.6,
|
||||
hsc2hs -in-ghc-tree,
|
||||
any.http-io-streams ==0.1.2.0,
|
||||
http-io-streams +brotli,
|
||||
any.indexed-profunctors ==0.1,
|
||||
any.integer-gmp ==1.0.2.0,
|
||||
any.integer-logarithms ==1.0.3,
|
||||
integer-logarithms -check-bounds +integer-gmp,
|
||||
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,
|
||||
any.math-functions ==0.3.3.0,
|
||||
math-functions +system-erf +system-expm1,
|
||||
any.megaparsec ==8.0.0,
|
||||
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.1.1.1,
|
||||
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.1,
|
||||
any.primitive-extras ==0.8,
|
||||
any.primitive-unlifted ==0.1.3.0,
|
||||
any.process ==1.6.5.0 || ==1.6.8.0,
|
||||
any.profunctors ==5.5.2,
|
||||
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,
|
||||
any.semigroupoids ==5.3.4,
|
||||
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.sop-core ==0.5.0.0,
|
||||
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.3.0,
|
||||
any.template-haskell ==2.14.0.0,
|
||||
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.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 || ==1.9.3,
|
||||
any.time-compat ==1.9.2.2,
|
||||
time-compat -old-locale,
|
||||
any.transformers ==0.5.6.2,
|
||||
any.transformers-base ==0.4.5.2,
|
||||
transformers-base +orphaninstances,
|
||||
any.transformers-compat ==0.6.5,
|
||||
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
|
||||
any.typed-process ==0.2.6.0,
|
||||
any.unix ==2.7.2.2,
|
||||
any.unix-bytestring ==0.3.7.3,
|
||||
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.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,
|
||||
any.word8 ==0.1.3,
|
||||
any.zlib ==0.6.2.1,
|
||||
zlib -non-blocking-ffi -pkg-config,
|
||||
any.zlib-bindings ==0.1.1.5
|
||||
234
ghcup.cabal
Normal file
234
ghcup.cabal
Normal file
@ -0,0 +1,234 @@
|
||||
cabal-version: 2.2
|
||||
|
||||
name: ghcup
|
||||
version: 0.1.0.0
|
||||
synopsis: ghc toolchain installer as an exe/library
|
||||
description: A rewrite of the shell script ghcup, for providing
|
||||
a more stable user experience and exposing an API.
|
||||
homepage: https://github.com/hasufell/ghcup-hs
|
||||
bug-reports: https://github.com/hasufell/ghcup-hs/issues
|
||||
license: LGPL-3.0-only
|
||||
license-file: LICENSE
|
||||
author: Julian Ospald
|
||||
maintainer: hasufell@posteo.de
|
||||
copyright: Julian Ospald 2020
|
||||
category: System
|
||||
build-type: Simple
|
||||
extra-source-files: CHANGELOG.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/hasufell/ghcup-hs
|
||||
|
||||
common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 }
|
||||
common aeson { build-depends: aeson >= 1.4 }
|
||||
common aeson-pretty { build-depends: aeson-pretty >= 0.8.8 }
|
||||
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 case-insensitive { build-depends: case-insensitive >= 1.2.1.0 }
|
||||
common containers { build-depends: containers >= 0.6 }
|
||||
common generics-sop { build-depends: generics-sop >= 0.5 }
|
||||
common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
|
||||
common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
|
||||
common hopenssl { build-depends: hopenssl >= 2.2.4 }
|
||||
common hpath { build-depends: hpath >= 0.11 }
|
||||
common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
|
||||
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
|
||||
common hpath-io { build-depends: hpath-io >= 0.13.1 }
|
||||
common hpath-posix { build-depends: hpath-posix >= 0.11.1 }
|
||||
common http-io-streams { build-depends: http-io-streams >= 0.1.2.0 }
|
||||
common io-streams { build-depends: io-streams >= 1.5 }
|
||||
common language-bash { build-depends: language-bash >= 0.9 }
|
||||
common lzma { build-depends: lzma >= 0.0.0.3 }
|
||||
common monad-logger { build-depends: monad-logger >= 0.3.31 }
|
||||
common mtl { build-depends: mtl >= 2.2 }
|
||||
common optics { build-depends: optics >= 0.2 }
|
||||
common optics-vl { build-depends: optics-vl >= 0.2 }
|
||||
common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 }
|
||||
common parsec { build-depends: parsec >= 3.1 }
|
||||
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.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.3.0 }
|
||||
common template-haskell { build-depends: template-haskell >= 2.7 }
|
||||
common terminal-progress-bar { build-depends: terminal-progress-bar >= 0.4.1 }
|
||||
common text { build-depends: text >= 1.2 }
|
||||
common text-icu { build-depends: text-icu >= 0.7 }
|
||||
common time { build-depends: time >= 1.9.3 }
|
||||
common transformers { build-depends: transformers >= 0.5 }
|
||||
common unix { build-depends: unix >= 2.7 }
|
||||
common unix-bytestring { build-depends: unix-bytestring >= 0.3 }
|
||||
common uri-bytestring { build-depends: uri-bytestring >= 0.3.2.2 }
|
||||
common utf8-string { build-depends: utf8-string >= 1.0 }
|
||||
common vector { build-depends: vector >= 0.12 }
|
||||
common versions { build-depends: versions >= 3.5 }
|
||||
common waargonaut { build-depends: waargonaut >= 0.8 }
|
||||
common word8 { build-depends: word8 >= 0.1.3 }
|
||||
common zlib { build-depends: zlib >= 0.6.2.1 }
|
||||
|
||||
|
||||
common config
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded
|
||||
default-extensions: LambdaCase
|
||||
, MultiWayIf
|
||||
, PackageImports
|
||||
, RecordWildCards
|
||||
, ScopedTypeVariables
|
||||
, StrictData
|
||||
, Strict
|
||||
, TupleSections
|
||||
|
||||
library
|
||||
import: config
|
||||
, base
|
||||
-- deps
|
||||
, HsOpenSSL
|
||||
, aeson
|
||||
, ascii-string
|
||||
, async
|
||||
, attoparsec
|
||||
, binary
|
||||
, bytestring
|
||||
, bzlib
|
||||
, case-insensitive
|
||||
, containers
|
||||
, generics-sop
|
||||
, haskus-utils-types
|
||||
, haskus-utils-variant
|
||||
, hopenssl
|
||||
, hpath
|
||||
, hpath-directory
|
||||
, hpath-filepath
|
||||
, hpath-io
|
||||
, hpath-posix
|
||||
, http-io-streams
|
||||
, io-streams
|
||||
, language-bash
|
||||
, lzma
|
||||
, monad-logger
|
||||
, mtl
|
||||
, optics
|
||||
, optics-vl
|
||||
, parsec
|
||||
, pretty-terminal
|
||||
, resourcet
|
||||
, safe
|
||||
, safe-exceptions
|
||||
, streamly
|
||||
, streamly-posix
|
||||
, streamly-bytestring
|
||||
, strict-base
|
||||
, string-interpolate
|
||||
, tar-bytestring
|
||||
, template-haskell
|
||||
, terminal-progress-bar
|
||||
, text
|
||||
, text-icu
|
||||
, time
|
||||
, transformers
|
||||
, unix
|
||||
, unix-bytestring
|
||||
, uri-bytestring
|
||||
, utf8-string
|
||||
, vector
|
||||
, versions
|
||||
, word8
|
||||
, zlib
|
||||
exposed-modules: GHCup
|
||||
GHCup.Download
|
||||
GHCup.Errors
|
||||
GHCup.Platform
|
||||
GHCup.Types
|
||||
GHCup.Types.JSON
|
||||
GHCup.Types.Optics
|
||||
GHCup.Utils
|
||||
GHCup.Utils.Bash
|
||||
GHCup.Utils.Dirs
|
||||
GHCup.Utils.File
|
||||
GHCup.Utils.Logger
|
||||
GHCup.Utils.Prelude
|
||||
GHCup.Utils.String.QQ
|
||||
GHCup.Utils.Version.QQ
|
||||
GHCup.Version
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
hs-source-dirs: lib
|
||||
|
||||
executable ghcup
|
||||
import: config
|
||||
, base
|
||||
--
|
||||
, bytestring
|
||||
, containers
|
||||
, haskus-utils-variant
|
||||
, monad-logger
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, text
|
||||
, versions
|
||||
, hpath
|
||||
, hpath-io
|
||||
, pretty-terminal
|
||||
, resourcet
|
||||
, string-interpolate
|
||||
, table-layout
|
||||
, uri-bytestring
|
||||
, utf8-string
|
||||
main-is: Main.hs
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: ghcup
|
||||
hs-source-dirs: app/ghcup
|
||||
default-language: Haskell2010
|
||||
|
||||
executable ghcup-gen
|
||||
import: config
|
||||
, base
|
||||
--
|
||||
, aeson
|
||||
, aeson-pretty
|
||||
, bytestring
|
||||
, containers
|
||||
, safe-exceptions
|
||||
, haskus-utils-variant
|
||||
, monad-logger
|
||||
, mtl
|
||||
, optics
|
||||
, optparse-applicative
|
||||
, text
|
||||
, versions
|
||||
, hpath
|
||||
, pretty-terminal
|
||||
, resourcet
|
||||
, string-interpolate
|
||||
, table-layout
|
||||
, transformers
|
||||
, uri-bytestring
|
||||
, utf8-string
|
||||
main-is: Main.hs
|
||||
other-modules: GHCupDownloads
|
||||
Validate
|
||||
-- other-extensions:
|
||||
build-depends: ghcup
|
||||
hs-source-dirs: app/ghcup-gen
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite ghcup-test
|
||||
default-language: Haskell2010
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: MyLibTest.hs
|
||||
build-depends: base ^>=4.12.0.0
|
||||
686
lib/GHCup.hs
Normal file
686
lib/GHCup.hs
Normal file
@ -0,0 +1,686 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module GHCup where
|
||||
|
||||
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
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
|
||||
import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.IO.Error
|
||||
import System.Posix.FilePath ( getSearchPath )
|
||||
import System.Posix.RawFilePath.Directory.Errors
|
||||
( hideError )
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text.Encoding as E
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ Tool installation ]--
|
||||
-------------------------
|
||||
|
||||
|
||||
|
||||
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 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
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
-- prepare paths
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
|
||||
liftE $ installCabal' archiveSubdir bindir
|
||||
pure ()
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Set GHC ]--
|
||||
---------------
|
||||
|
||||
|
||||
|
||||
-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
|
||||
-- on `SetGHC`:
|
||||
--
|
||||
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
-- * SetGHC_XY: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
-- * SetGHC_XYZ: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
--
|
||||
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
|
||||
-- for `SetGHCOnly` constructor.
|
||||
setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> SetGHC
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
setGHC ver sghc = do
|
||||
let verBS = verToBS ver
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
|
||||
-- symlink destination
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
|
||||
|
||||
-- first delete the old symlinks (this fixes compatibility issues
|
||||
-- with old ghcup)
|
||||
case sghc of
|
||||
SetGHCOnly -> liftE $ rmPlain ver
|
||||
SetGHC_XY -> lift $ rmMajorSymlinks ver
|
||||
SetGHC_XYZ -> lift $ rmMinorSymlinks ver
|
||||
|
||||
-- for ghc tools (ghc, ghci, haddock, ...)
|
||||
verfiles <- ghcToolFiles ver
|
||||
forM_ verfiles $ \file -> do
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> file)
|
||||
targetFile <- case sghc of
|
||||
SetGHCOnly -> pure file
|
||||
SetGHC_XY -> do
|
||||
major' <-
|
||||
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
|
||||
<$> getGHCMajor ver
|
||||
parseRel (toFilePath file <> B.singleton _hyphen <> major')
|
||||
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
|
||||
-- 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
|
||||
lift $ symlinkShareDir ghcdir verBS
|
||||
|
||||
pure ()
|
||||
|
||||
where
|
||||
|
||||
symlinkShareDir :: (MonadIO m, MonadLogger m)
|
||||
=> Path Abs
|
||||
-> ByteString
|
||||
-> m ()
|
||||
symlinkShareDir ghcdir verBS = do
|
||||
destdir <- liftIO $ ghcupBaseDir
|
||||
case sghc of
|
||||
SetGHCOnly -> do
|
||||
let sharedir = [rel|share|] :: Path Rel
|
||||
let fullsharedir = ghcdir </> 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 ()
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ List tools ]--
|
||||
------------------
|
||||
|
||||
|
||||
data ListCriteria = ListInstalled
|
||||
| ListSet
|
||||
deriving Show
|
||||
|
||||
data ListResult = ListResult
|
||||
{ lTool :: Tool
|
||||
, lVer :: Version
|
||||
, lTag :: [Tag]
|
||||
, lInstalled :: Bool
|
||||
, lSet :: Bool
|
||||
, fromSrc :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
availableToolVersions :: GHCupDownloads -> Tool -> [(Version, [Tag])]
|
||||
availableToolVersions av tool = toListOf
|
||||
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
|
||||
av
|
||||
|
||||
|
||||
listVersions :: GHCupDownloads
|
||||
-> Maybe Tool
|
||||
-> Maybe ListCriteria
|
||||
-> IO [ListResult]
|
||||
listVersions av lt criteria = case lt of
|
||||
Just t -> do
|
||||
filter' <$> forM (availableToolVersions av t) (toListResult t)
|
||||
Nothing -> do
|
||||
ghcvers <- listVersions av (Just GHC) criteria
|
||||
cabalvers <- listVersions av (Just Cabal) criteria
|
||||
ghcupvers <- listVersions av (Just GHCup) criteria
|
||||
pure (ghcvers <> cabalvers <> ghcupvers)
|
||||
|
||||
where
|
||||
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
|
||||
toListResult t (v, tags) = case t 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, 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
|
||||
Nothing -> lr
|
||||
Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr
|
||||
Just ListSet -> filter (\ListResult {..} -> lSet) lr
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ GHC rm ]--
|
||||
--------------
|
||||
|
||||
|
||||
-- | This function may throw and crash in various ways.
|
||||
rmGHCVer :: (MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmGHCVer ver = do
|
||||
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
|
||||
dir <- liftIO $ ghcupGHCDir ver
|
||||
let d' = toFilePath dir
|
||||
exists <- liftIO $ doesDirectoryExist dir
|
||||
|
||||
|
||||
if exists
|
||||
then do
|
||||
-- this isn't atomic, order matters
|
||||
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
|
||||
liftIO $ deleteDirRecursive dir
|
||||
|
||||
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
|
||||
lift $ rmMinorSymlinks ver
|
||||
|
||||
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
|
||||
-- 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 SetGHC_XY)
|
||||
|
||||
|
||||
when isSetGHC $ do
|
||||
lift $ $(logInfo) [i|Removing ghc symlinks|]
|
||||
liftE $ rmPlain ver
|
||||
|
||||
liftIO
|
||||
$ ghcupBaseDir
|
||||
>>= hideError doesNotExistErrorType
|
||||
. deleteFile
|
||||
. (</> ([rel|share|] :: Path Rel))
|
||||
else throwE (NotInstalled GHC ver)
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Debug info ]--
|
||||
------------------
|
||||
|
||||
|
||||
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
|
||||
=> Excepts
|
||||
'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
|
||||
m
|
||||
DebugInfo
|
||||
getDebugInfo = do
|
||||
diBaseDir <- liftIO $ ghcupBaseDir
|
||||
diBinDir <- liftIO $ ghcupBinDir
|
||||
diGHCDir <- liftIO $ ghcupGHCBaseDir
|
||||
diCacheDir <- liftIO $ ghcupCacheDir
|
||||
diURLSource <- lift $ getUrlSource
|
||||
diArch <- lE getArchitecture
|
||||
diPlatform <- liftE $ getPlatform
|
||||
pure $ DebugInfo { .. }
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Compile ]--
|
||||
---------------
|
||||
|
||||
|
||||
compileGHC :: ( MonadMask m
|
||||
, MonadReader Settings m
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadFail m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version -- ^ version to install
|
||||
-> Version -- ^ version to bootstrap with
|
||||
-> Maybe Int -- ^ jobs
|
||||
-> Maybe (Path Abs) -- ^ build config
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, DownloadFailed
|
||||
, GHCupSetError
|
||||
, NoDownload
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
compileGHC dls tver bver jobs mbuildConfig = do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
|
||||
whenM (liftIO $ toolAlreadyInstalled GHC tver)
|
||||
(throwE $ AlreadyInstalled GHC tver)
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <- preview (ix GHC % ix tver % viSourceDL % _Just) dls ?? NoDownload
|
||||
dl <- liftE $ downloadCached dlInfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
|
||||
bghc <- parseRel ([s|ghc-|] <> verToBS bver)
|
||||
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
||||
ghcdir <- liftIO $ ghcupGHCDir tver
|
||||
|
||||
catchAllE
|
||||
(\es ->
|
||||
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
|
||||
>> throwE (BuildFailed workdir es)
|
||||
)
|
||||
$ compile bghc ghcdir workdir
|
||||
markSrcBuilt ghcdir workdir
|
||||
|
||||
-- only clean up dir if the build succeeded
|
||||
liftIO $ deleteDirRecursive tmpUnpack
|
||||
|
||||
reThrowAll GHCupSetError $ postGHCInstall tver
|
||||
pure ()
|
||||
|
||||
where
|
||||
defaultConf = [s|
|
||||
V=0
|
||||
BUILD_MAN = NO
|
||||
BUILD_SPHINX_HTML = NO
|
||||
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)
|
||||
|
||||
|
||||
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)
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--[ Upgrade GHCup ]--
|
||||
---------------------
|
||||
|
||||
|
||||
upgradeGHCup :: ( MonadMask m
|
||||
, MonadReader Settings m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
|
||||
-> Excepts
|
||||
'[ CopyError
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
]
|
||||
m
|
||||
Version
|
||||
upgradeGHCup dls mtarget = do
|
||||
lift $ $(logInfo) [i|Upgrading GHCup...|]
|
||||
let latestVer = head $ getTagged dls GHCup Latest
|
||||
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
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||
(dest </> fn)
|
||||
Overwrite
|
||||
Just fullDest -> liftIO $ copyFile p fullDest Overwrite
|
||||
pure latestVer
|
||||
|
||||
|
||||
|
||||
-------------
|
||||
--[ Other ]--
|
||||
-------------
|
||||
|
||||
|
||||
-- | 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
|
||||
liftE $ setGHC ver SetGHC_XYZ
|
||||
|
||||
-- Create ghc-x.y symlinks. This may not be the current
|
||||
-- version, create it regardless.
|
||||
(mj, mi) <- liftIO $ getGHCMajor ver
|
||||
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
|
||||
615
lib/GHCup/Download.hs
Normal file
615
lib/GHCup/Download.hs
Normal file
@ -0,0 +1,615 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
|
||||
module GHCup.Download where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.Aeson
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.ByteString.Builder
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Text.Read
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.POSIX
|
||||
import Data.Time.Format
|
||||
import Data.Versions
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Network.Http.Client hiding ( URL )
|
||||
import OpenSSL.Digest
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.IO.Error
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( fdWrite )
|
||||
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.CaseInsensitive as CI
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified System.IO.Streams as Streams
|
||||
import qualified System.Posix.Files.ByteString as PF
|
||||
import qualified System.Posix.RawFilePath.Directory
|
||||
as RD
|
||||
|
||||
|
||||
|
||||
ghcupURL :: URI
|
||||
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ High-level ]--
|
||||
------------------
|
||||
|
||||
|
||||
-- | Downloads the download information! But only if we need to ;P
|
||||
getDownloads :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Excepts '[JSONError , DownloadFailed] m GHCupDownloads
|
||||
getDownloads = do
|
||||
urlSource <- lift getUrlSource
|
||||
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
|
||||
case urlSource of
|
||||
GHCupURL -> do
|
||||
bs <- reThrowAll DownloadFailed $ dl ghcupURL
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSource url) -> do
|
||||
bs <- reThrowAll DownloadFailed $ dl url
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSpec av) -> pure $ av
|
||||
|
||||
where
|
||||
-- First check if the json file is in the ~/.ghcup/cache dir
|
||||
-- and check it's access time. If it has been accessed within the
|
||||
-- last 5 minutes, just reuse it.
|
||||
--
|
||||
-- If not, then send a HEAD request and check for modification time.
|
||||
-- Only download the file if the modification time is newer
|
||||
-- than the local file.
|
||||
--
|
||||
-- Always save the local file with the mod time of the remote file.
|
||||
dl :: forall m1
|
||||
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m1
|
||||
L.ByteString
|
||||
dl uri' = do
|
||||
let path = view pathL' uri'
|
||||
json_file <- (liftIO $ ghcupCacheDir)
|
||||
>>= \cacheDir -> (cacheDir </>) <$> urlBaseName path
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
if e
|
||||
then do
|
||||
accessTime <-
|
||||
PF.accessTimeHiRes
|
||||
<$> (liftIO $ PF.getFileStatus (toFilePath json_file))
|
||||
currentTime <- liftIO $ getPOSIXTime
|
||||
|
||||
-- access time won't work on most linuxes, but we can try regardless
|
||||
if (currentTime - accessTime) > 300
|
||||
then do -- no access in last 5 minutes, re-check upstream mod time
|
||||
getModTime >>= \case
|
||||
Just modTime -> do
|
||||
fileMod <- liftIO $ getModificationTime json_file
|
||||
if modTime > fileMod
|
||||
then do
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ writeFileWithModTime modTime json_file bs
|
||||
pure bs
|
||||
else liftIO $ readFile json_file
|
||||
Nothing -> do
|
||||
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
|
||||
liftIO $ deleteFile json_file
|
||||
liftE $ downloadBS uri'
|
||||
else -- access in less than 5 minutes, re-use file
|
||||
liftIO $ readFile json_file
|
||||
else do
|
||||
getModTime >>= \case
|
||||
Just modTime -> do
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ writeFileWithModTime modTime json_file bs
|
||||
pure bs
|
||||
Nothing -> do
|
||||
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
|
||||
liftE $ downloadBS uri'
|
||||
|
||||
where
|
||||
getModTime = do
|
||||
headers <-
|
||||
handleIO (\_ -> pure mempty)
|
||||
$ liftE
|
||||
$ ( catchAllE
|
||||
(\_ ->
|
||||
pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
|
||||
)
|
||||
$ getHead uri'
|
||||
)
|
||||
pure $ parseModifiedHeader headers
|
||||
|
||||
|
||||
parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
|
||||
parseModifiedHeader headers =
|
||||
(M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM
|
||||
True
|
||||
defaultTimeLocale
|
||||
"%a, %d %b %Y %H:%M:%S %Z"
|
||||
(T.unpack . E.decodeUtf8 $ h)
|
||||
|
||||
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
|
||||
writeFileWithModTime utctime path content = do
|
||||
let mod_time = utcTimeToPOSIXSeconds utctime
|
||||
writeFileL path (Just newFilePerms) content
|
||||
setModificationTimeHiRes path mod_time
|
||||
|
||||
|
||||
|
||||
getDownloadInfo :: ( MonadLogger m
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Tool
|
||||
-> Version
|
||||
-> Maybe PlatformRequest
|
||||
-> Excepts
|
||||
'[ DistroNotFound
|
||||
, NoCompatiblePlatform
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
]
|
||||
m
|
||||
DownloadInfo
|
||||
getDownloadInfo bDls t v mpfReq = do
|
||||
(PlatformRequest arch' plat ver) <- case mpfReq of
|
||||
Just x -> pure x
|
||||
Nothing -> do
|
||||
(PlatformResult rp rv) <- liftE getPlatform
|
||||
ar <- lE getArchitecture
|
||||
pure $ PlatformRequest ar rp rv
|
||||
|
||||
lE $ getDownloadInfo' t v arch' plat ver bDls
|
||||
|
||||
|
||||
getDownloadInfo' :: Tool
|
||||
-> Version
|
||||
-- ^ tool version
|
||||
-> Architecture
|
||||
-- ^ user arch
|
||||
-> Platform
|
||||
-- ^ user platform
|
||||
-> Maybe Versioning
|
||||
-- ^ optional version of the platform
|
||||
-> GHCupDownloads
|
||||
-> Either NoDownload DownloadInfo
|
||||
getDownloadInfo' t v a p mv dls = maybe
|
||||
(Left NoDownload)
|
||||
Right
|
||||
(with_distro <|> without_distro_ver <|> without_distro)
|
||||
|
||||
where
|
||||
with_distro = distro_preview id id
|
||||
without_distro_ver = distro_preview id (const Nothing)
|
||||
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
|
||||
|
||||
distro_preview f g =
|
||||
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
|
||||
|
||||
|
||||
-- | Tries to download from the given http or https url
|
||||
-- and saves the result in continuous memory into a file.
|
||||
-- If the filename is not provided, then we:
|
||||
-- 1. try to guess the filename from the url path
|
||||
-- 2. otherwise create a random file
|
||||
--
|
||||
-- The file must not exist.
|
||||
download :: ( MonadMask m
|
||||
, MonadReader Settings m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Path Abs -- ^ destination dir
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> 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
|
||||
cp = do
|
||||
-- destination dir must exist
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
|
||||
destFile <- getDestFile
|
||||
fromFile <- parseAbs path
|
||||
liftIO $ copyFile fromFile destFile Strict
|
||||
pure destFile
|
||||
dl = do
|
||||
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
|
||||
lift $ $(logInfo) [i|downloading: #{uri'}|]
|
||||
|
||||
(https, host, fullPath, port) <- reThrowAll DownloadFailed
|
||||
$ uriToQuadruple (view dlUri dli)
|
||||
|
||||
-- destination dir must exist
|
||||
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
|
||||
destFile <- getDestFile
|
||||
|
||||
-- download
|
||||
fd <- liftIO $ createRegularFileFd newFilePerms destFile
|
||||
let stepper = fdWrite fd
|
||||
flip finally (liftIO $ closeFd fd)
|
||||
$ reThrowAll DownloadFailed
|
||||
$ downloadInternal True https host fullPath port stepper
|
||||
|
||||
liftE $ checkDigest dli destFile
|
||||
pure destFile
|
||||
|
||||
-- Manage to find a file we can write the body into.
|
||||
getDestFile :: MonadThrow m => m (Path Abs)
|
||||
getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
|
||||
|
||||
path = view (dlUri % pathL') dli
|
||||
|
||||
|
||||
-- | Download into tmpdir or use cached version, if it exists. If filename
|
||||
-- is omitted, infers the filename from the url.
|
||||
downloadCached :: ( MonadMask m
|
||||
, MonadResource m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> DownloadInfo
|
||||
-> Maybe (Path Rel) -- ^ optional filename
|
||||
-> Excepts '[DigestError , DownloadFailed] m (Path Abs)
|
||||
downloadCached dli mfn = do
|
||||
cache <- lift getCache
|
||||
case cache of
|
||||
True -> do
|
||||
cachedir <- liftIO $ ghcupCacheDir
|
||||
fn <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
|
||||
let cachfile = cachedir </> fn
|
||||
fileExists <- liftIO $ doesFileExist cachfile
|
||||
if
|
||||
| fileExists -> do
|
||||
liftE $ checkDigest dli cachfile
|
||||
pure $ cachfile
|
||||
| otherwise -> liftE $ download dli cachedir mfn
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
liftE $ download dli tmp mfn
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Low-level ]--
|
||||
------------------
|
||||
|
||||
|
||||
-- | This is used for downloading the JSON.
|
||||
downloadBS :: (MonadCatch m, MonadIO m)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m
|
||||
L.ByteString
|
||||
downloadBS uri'
|
||||
| scheme == [s|https|]
|
||||
= dl True
|
||||
| scheme == [s|http|]
|
||||
= dl False
|
||||
| scheme == [s|file|]
|
||||
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
|
||||
$ (liftIO $ RD.readFile path)
|
||||
| otherwise
|
||||
= throwE UnsupportedScheme
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
path = view pathL' uri'
|
||||
dl https = do
|
||||
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
liftE $ downloadBS' https host' fullPath' port'
|
||||
|
||||
|
||||
-- | Load the result of this download into memory at once.
|
||||
downloadBS' :: MonadIO m
|
||||
=> Bool -- ^ https?
|
||||
-> ByteString -- ^ host (e.g. "www.example.com")
|
||||
-> ByteString -- ^ path (e.g. "/my/file") including query
|
||||
-> Maybe Int -- ^ optional port (e.g. 3000)
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m
|
||||
(L.ByteString)
|
||||
downloadBS' https host path port = do
|
||||
bref <- liftIO $ newIORef (mempty :: Builder)
|
||||
let stepper bs = modifyIORef bref (<> byteString bs)
|
||||
downloadInternal False https host path port stepper
|
||||
liftIO (readIORef bref <&> toLazyByteString)
|
||||
|
||||
|
||||
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)
|
||||
|
||||
where
|
||||
go redirs progressBar https host path port consumer = do
|
||||
r <- liftIO $ withConnection' https host port action
|
||||
veitherToExcepts r >>= \case
|
||||
Just r' ->
|
||||
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
|
||||
Nothing -> pure ()
|
||||
where
|
||||
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 -> do
|
||||
forM_ mpb $ \pb -> incProgress pb (BS.length bs)
|
||||
void $ consumer bs
|
||||
Nothing -> pure ()
|
||||
)
|
||||
liftIO $ Streams.connect i' outStream
|
||||
|
||||
|
||||
|
||||
getHead :: (MonadCatch m, MonadIO m)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m
|
||||
(M.Map (CI ByteString) ByteString)
|
||||
getHead uri' | scheme == [s|https|] = head' True
|
||||
| scheme == [s|http|] = head' False
|
||||
| otherwise = throwE UnsupportedScheme
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
head' https = do
|
||||
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
liftE $ headInternal https host' fullPath' port'
|
||||
|
||||
|
||||
|
||||
headInternal :: MonadIO m
|
||||
=> Bool -- ^ https?
|
||||
-> ByteString -- ^ host
|
||||
-> ByteString -- ^ path with query
|
||||
-> Maybe Int -- ^ optional port
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, TooManyRedirs
|
||||
, NoLocationHeader
|
||||
]
|
||||
m
|
||||
(M.Map (CI ByteString) ByteString)
|
||||
headInternal = go (5 :: Int)
|
||||
|
||||
where
|
||||
go redirs https host path port = do
|
||||
r <- liftIO $ withConnection' https host port action
|
||||
veitherToExcepts r >>= \case
|
||||
Left r' ->
|
||||
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
|
||||
Right hs -> pure hs
|
||||
where
|
||||
|
||||
action c = do
|
||||
let q = buildRequest1 $ http HEAD path
|
||||
|
||||
sendRequest c q emptyBody
|
||||
|
||||
unsafeReceiveResponse
|
||||
c
|
||||
(\r _ -> runE $ do
|
||||
let scode = getStatusCode r
|
||||
if
|
||||
| scode >= 200 && scode < 300 -> do
|
||||
let headers = getHeaderMap r
|
||||
pure $ Right $ headers
|
||||
| scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
|
||||
Just r' -> pure $ Left $ 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) https' host' fullPath' port'
|
||||
Left e -> throwE e
|
||||
|
||||
|
||||
withConnection' :: Bool
|
||||
-> ByteString
|
||||
-> Maybe Int
|
||||
-> (Connection -> IO a)
|
||||
-> IO a
|
||||
withConnection' https host port action = bracket acquire closeConnection action
|
||||
|
||||
where
|
||||
acquire = case https of
|
||||
True -> do
|
||||
ctx <- baselineContextSSL
|
||||
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
|
||||
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
|
||||
|
||||
|
||||
-- | 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)
|
||||
=> DownloadInfo
|
||||
-> Path Abs
|
||||
-> Excepts '[DigestError] m ()
|
||||
checkDigest dli file = do
|
||||
verify <- lift ask <&> (not . noVerify)
|
||||
when verify $ do
|
||||
let p' = toFilePath file
|
||||
lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
|
||||
c <- liftIO $ readFile file
|
||||
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
|
||||
eDigest = view dlHash dli
|
||||
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
|
||||
124
lib/GHCup/Errors.hs
Normal file
124
lib/GHCup/Errors.hs
Normal file
@ -0,0 +1,124 @@
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module GHCup.Errors where
|
||||
|
||||
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 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
|
||||
|
||||
-- | The archive format is unknown. We don't know how to extract it.
|
||||
data UnknownArchive = UnknownArchive ByteString
|
||||
deriving Show
|
||||
|
||||
-- | The scheme is not supported (such as ftp).
|
||||
data UnsupportedScheme = UnsupportedScheme
|
||||
deriving Show
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | The tool (such as GHC) is already installed with that version.
|
||||
data AlreadyInstalled = AlreadyInstalled Tool Version
|
||||
deriving Show
|
||||
|
||||
-- | 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
|
||||
166
lib/GHCup/Platform.hs
Normal file
166
lib/GHCup/Platform.hs
Normal file
@ -0,0 +1,166 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module GHCup.Platform where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Bash
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.Info
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.ICU as ICU
|
||||
|
||||
--------------------------
|
||||
--[ Platform detection ]--
|
||||
--------------------------
|
||||
|
||||
|
||||
getArchitecture :: Either NoCompatibleArch Architecture
|
||||
getArchitecture = case arch of
|
||||
"x86_64" -> Right A_64
|
||||
"i386" -> Right A_32
|
||||
what -> Left (NoCompatibleArch what)
|
||||
|
||||
|
||||
|
||||
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
'[NoCompatiblePlatform , DistroNotFound]
|
||||
m
|
||||
PlatformResult
|
||||
getPlatform = do
|
||||
pfr <- case os of
|
||||
"linux" -> do
|
||||
(distro, ver) <- liftE getLinuxDistro
|
||||
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
|
||||
-- TODO: these are not verified
|
||||
"darwin" ->
|
||||
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
|
||||
"freebsd" -> do
|
||||
ver <- getFreeBSDVersion
|
||||
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
||||
what -> throwE $ NoCompatiblePlatform what
|
||||
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
|
||||
pure pfr
|
||||
where getFreeBSDVersion = pure Nothing
|
||||
|
||||
|
||||
getLinuxDistro :: (MonadCatch m, MonadIO m)
|
||||
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
|
||||
getLinuxDistro = do
|
||||
-- TODO: don't do alternative on IO, because it hides bugs
|
||||
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
|
||||
[ try_os_release
|
||||
, try_lsb_release_cmd
|
||||
, try_lsb_release
|
||||
, try_redhat_release
|
||||
, try_debian_version
|
||||
]
|
||||
let parsedVer = ver >>= either (const Nothing) Just . versioning
|
||||
distro = if
|
||||
| hasWord name ["debian"] -> Debian
|
||||
| hasWord name ["ubuntu"] -> Ubuntu
|
||||
| hasWord name ["linuxmint", "Linux Mint"] -> Mint
|
||||
| hasWord name ["fedora"] -> Fedora
|
||||
| hasWord name ["centos"] -> CentOS
|
||||
| hasWord name ["Red Hat"] -> RedHat
|
||||
| hasWord name ["alpine"] -> Alpine
|
||||
| hasWord name ["exherbo"] -> Exherbo
|
||||
| hasWord name ["gentoo"] -> Gentoo
|
||||
| hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
|
||||
| otherwise -> UnknownLinux
|
||||
pure (distro, parsedVer)
|
||||
where
|
||||
hasWord t matches = foldr
|
||||
(\x y ->
|
||||
( isJust
|
||||
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
|
||||
$ t
|
||||
)
|
||||
|| y
|
||||
)
|
||||
False
|
||||
(T.pack <$> matches)
|
||||
|
||||
os_release :: Path Abs
|
||||
os_release = [abs|/etc/os-release|]
|
||||
lsb_release :: Path Abs
|
||||
lsb_release = [abs|/etc/lsb-release|]
|
||||
lsb_release_cmd :: Path Rel
|
||||
lsb_release_cmd = [rel|lsb-release|]
|
||||
redhat_release :: Path Abs
|
||||
redhat_release = [abs|/etc/redhat-release|]
|
||||
debian_version :: Path Abs
|
||||
debian_version = [abs|/etc/debian_version|]
|
||||
|
||||
try_os_release :: IO (Text, Maybe Text)
|
||||
try_os_release = do
|
||||
(Just name) <- getAssignmentValueFor os_release "NAME"
|
||||
ver <- getAssignmentValueFor os_release "VERSION_ID"
|
||||
pure (T.pack name, fmap T.pack ver)
|
||||
|
||||
try_lsb_release_cmd :: IO (Text, Maybe Text)
|
||||
try_lsb_release_cmd = do
|
||||
(Just _) <- findExecutable lsb_release_cmd
|
||||
name <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
|
||||
ver <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
|
||||
pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
|
||||
|
||||
try_lsb_release :: IO (Text, Maybe Text)
|
||||
try_lsb_release = do
|
||||
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
|
||||
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
|
||||
pure (T.pack name, fmap T.pack ver)
|
||||
|
||||
try_redhat_release :: IO (Text, Maybe Text)
|
||||
try_redhat_release = do
|
||||
t <- fmap lBS2sT $ readFile redhat_release
|
||||
let nameRe n =
|
||||
join
|
||||
. fmap (ICU.group 0)
|
||||
. ICU.find
|
||||
(ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
|
||||
$ t
|
||||
verRe =
|
||||
join
|
||||
. fmap (ICU.group 0)
|
||||
. ICU.find
|
||||
(ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
|
||||
$ t
|
||||
(Just name) <- pure
|
||||
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
|
||||
pure (name, verRe)
|
||||
|
||||
try_debian_version :: IO (Text, Maybe Text)
|
||||
try_debian_version = do
|
||||
ver <- readFile debian_version
|
||||
pure (T.pack "debian", Just $ lBS2sT ver)
|
||||
144
lib/GHCup/Types.hs
Normal file
144
lib/GHCup/Types.hs
Normal file
@ -0,0 +1,144 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module GHCup.Types where
|
||||
|
||||
import Data.Map.Strict ( Map )
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import URI.ByteString
|
||||
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--[ Download Tree ]--
|
||||
---------------------
|
||||
|
||||
|
||||
-- | Description of all binary and source downloads. This is a tree
|
||||
-- of nested maps.
|
||||
type GHCupDownloads = Map Tool ToolVersionSpec
|
||||
type ToolVersionSpec = Map Version VersionInfo
|
||||
type ArchitectureSpec = Map Architecture PlatformSpec
|
||||
type PlatformSpec = Map Platform PlatformVersionSpec
|
||||
type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
|
||||
|
||||
|
||||
-- | An installable tool.
|
||||
data Tool = GHC
|
||||
| Cabal
|
||||
| GHCup
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
-- | All necessary information of a tool version, including
|
||||
-- source download and per-architecture downloads.
|
||||
data VersionInfo = VersionInfo
|
||||
{ _viTags :: [Tag] -- ^ version specific tag
|
||||
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
|
||||
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
-- | A tag. These are currently attached to a version of a tool.
|
||||
data Tag = Latest
|
||||
| Recommended
|
||||
deriving (Ord, Eq, Show)
|
||||
|
||||
|
||||
data Architecture = A_64
|
||||
| A_32
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
data Platform = Linux LinuxDistro
|
||||
-- ^ must exit
|
||||
| Darwin
|
||||
-- ^ must exit
|
||||
| FreeBSD
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
data LinuxDistro = Debian
|
||||
| Ubuntu
|
||||
| Mint
|
||||
| Fedora
|
||||
| CentOS
|
||||
| RedHat
|
||||
| Alpine
|
||||
| AmazonLinux
|
||||
-- rolling
|
||||
| Gentoo
|
||||
| Exherbo
|
||||
-- not known
|
||||
| UnknownLinux
|
||||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
-- | An encapsulation of a download. This can be used
|
||||
-- to download, extract and install a tool.
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ _dlUri :: URI
|
||||
, _dlSubdir :: Maybe (Path Rel)
|
||||
, _dlHash :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Others ]--
|
||||
--------------
|
||||
|
||||
|
||||
-- | Where to fetch GHCupDownloads from.
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource URI
|
||||
| OwnSpec GHCupDownloads
|
||||
deriving Show
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
, urlSource :: URLSource
|
||||
, noVerify :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
data DebugInfo = DebugInfo
|
||||
{ diBaseDir :: Path Abs
|
||||
, diBinDir :: Path Abs
|
||||
, diGHCDir :: Path Abs
|
||||
, diCacheDir :: Path Abs
|
||||
, diURLSource :: URLSource
|
||||
, diArch :: Architecture
|
||||
, diPlatform :: PlatformResult
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
|
||||
| SetGHC_XY -- ^ ghc-x.y
|
||||
| SetGHC_XYZ -- ^ ghc-x.y.z
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
data PlatformResult = PlatformResult
|
||||
{ _platform :: Platform
|
||||
, _distroVersion :: Maybe Versioning
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data PlatformRequest = PlatformRequest
|
||||
{ _rArch :: Architecture
|
||||
, _rPlatform :: Platform
|
||||
, _rVersion :: Maybe Versioning
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
149
lib/GHCup/Types/JSON.hs
Normal file
149
lib/GHCup/Types/JSON.hs
Normal file
@ -0,0 +1,149 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module GHCup.Types.JSON where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.Aeson.Types
|
||||
import Data.Text.Encoding ( decodeUtf8 )
|
||||
import Data.Text.Encoding as E
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import HPath
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
|
||||
|
||||
|
||||
instance ToJSON URI where
|
||||
toJSON = toJSON . decodeUtf8 . serializeURIRef'
|
||||
|
||||
instance FromJSON URI where
|
||||
parseJSON = withText "URL" $ \t ->
|
||||
case parseURI strictURIParserOptions (encodeUtf8 t) of
|
||||
Right x -> pure x
|
||||
Left e -> fail . show $ e
|
||||
|
||||
instance ToJSON Versioning where
|
||||
toJSON = toJSON . prettyV
|
||||
|
||||
instance FromJSON Versioning where
|
||||
parseJSON = withText "Versioning" $ \t -> case versioning t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Version (FromJSON)" <> show e
|
||||
|
||||
instance ToJSONKey Versioning where
|
||||
toJSONKey = toJSONKeyText $ \x -> prettyV x
|
||||
|
||||
instance FromJSONKey Versioning where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> case versioning t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Versioning (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey (Maybe Versioning) where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Just x -> prettyV x
|
||||
Nothing -> T.pack "unknown_version"
|
||||
|
||||
instance FromJSONKey (Maybe Versioning) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
|
||||
where
|
||||
just t = case versioning t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey Platform where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Darwin -> T.pack "Darwin"
|
||||
FreeBSD -> T.pack "FreeBSD"
|
||||
Linux d -> T.pack ("Linux_" <> show d)
|
||||
|
||||
instance FromJSONKey Platform where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> if
|
||||
| T.pack "Darwin" == t -> pure Darwin
|
||||
| T.pack "FreeBSD" == t -> pure FreeBSD
|
||||
| T.pack "Linux_" `T.isPrefixOf` t -> case
|
||||
T.stripPrefix (T.pack "Linux_") t
|
||||
of
|
||||
Just dstr ->
|
||||
case
|
||||
(decodeStrict (E.encodeUtf8 (T.pack "\"" <> dstr <> T.pack "\"")) :: Maybe
|
||||
LinuxDistro
|
||||
)
|
||||
of
|
||||
Just d -> pure $ Linux d
|
||||
Nothing ->
|
||||
fail
|
||||
$ "Unexpected failure in decoding LinuxDistro: "
|
||||
<> show dstr
|
||||
Nothing -> fail "Unexpected failure in Platform stripPrefix"
|
||||
| otherwise -> fail $ "Failure in Platform (FromJSONKey)"
|
||||
|
||||
instance ToJSONKey Architecture where
|
||||
toJSONKey = genericToJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance FromJSONKey Architecture where
|
||||
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance ToJSON Version where
|
||||
toJSON = toJSON . prettyVer
|
||||
|
||||
instance FromJSON Version where
|
||||
parseJSON = withText "Version" $ \t -> case version t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Version (FromJSON)" <> show e
|
||||
|
||||
instance ToJSONKey Version where
|
||||
toJSONKey = toJSONKeyText $ \x -> prettyVer x
|
||||
|
||||
instance FromJSONKey Version where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> case version t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Version (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey Tool where
|
||||
toJSONKey = genericToJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance FromJSONKey Tool where
|
||||
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance ToJSON (Path Rel) where
|
||||
toJSON p = case and . fmap isAscii . BS.unpack $ fp of
|
||||
True -> toJSON . E.decodeUtf8 $ fp
|
||||
False -> String [s|/not/a/valid/path|]
|
||||
where fp = toFilePath p
|
||||
|
||||
instance FromJSON (Path Rel) where
|
||||
parseJSON = withText "HPath Rel" $ \t -> do
|
||||
let d = encodeUtf8 t
|
||||
case parseRel d of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
|
||||
48
lib/GHCup/Types/Optics.hs
Normal file
48
lib/GHCup/Types/Optics.hs
Normal file
@ -0,0 +1,48 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GHCup.Types.Optics where
|
||||
|
||||
import GHCup.Types
|
||||
|
||||
import Data.ByteString ( ByteString )
|
||||
import Optics
|
||||
import URI.ByteString
|
||||
|
||||
makePrisms ''Tool
|
||||
makePrisms ''Architecture
|
||||
makePrisms ''LinuxDistro
|
||||
makePrisms ''Platform
|
||||
makePrisms ''Tag
|
||||
|
||||
makeLenses ''PlatformResult
|
||||
makeLenses ''DownloadInfo
|
||||
makeLenses ''Tag
|
||||
makeLenses ''VersionInfo
|
||||
|
||||
|
||||
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
|
||||
uriSchemeL' = lensVL uriSchemeL
|
||||
|
||||
schemeBSL' :: Lens' Scheme ByteString
|
||||
schemeBSL' = lensVL schemeBSL
|
||||
|
||||
authorityL' :: Lens' (URIRef a) (Maybe Authority)
|
||||
authorityL' = lensVL authorityL
|
||||
|
||||
authorityHostL' :: Lens' Authority Host
|
||||
authorityHostL' = lensVL authorityHostL
|
||||
|
||||
authorityPortL' :: Lens' Authority (Maybe Port)
|
||||
authorityPortL' = lensVL authorityPortL
|
||||
|
||||
portNumberL' :: Lens' Port Int
|
||||
portNumberL' = lensVL portNumberL
|
||||
|
||||
hostBSL' :: Lens' Host ByteString
|
||||
hostBSL' = lensVL hostBSL
|
||||
|
||||
pathL' :: Lens' (URIRef a) ByteString
|
||||
pathL' = lensVL pathL
|
||||
|
||||
queryL' :: Lens' (URIRef a) Query
|
||||
queryL' = lensVL queryL
|
||||
330
lib/GHCup/Utils.hs
Normal file
330
lib/GHCup/Utils.hs
Normal file
@ -0,0 +1,330 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module GHCup.Utils
|
||||
( module GHCup.Utils.Dirs
|
||||
, module GHCup.Utils
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.Attoparsec.ByteString
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Versions
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import Safe
|
||||
import System.IO.Error
|
||||
import System.Posix.FilePath ( takeFileName )
|
||||
import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
import qualified Codec.Compression.BZip as BZip
|
||||
import qualified Codec.Compression.GZip as GZip
|
||||
import qualified Codec.Compression.Lzma as Lzma
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text.Encoding as E
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
------------------------
|
||||
--[ Symlink handling ]--
|
||||
------------------------
|
||||
|
||||
|
||||
-- | The symlink destination of a ghc tool.
|
||||
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> Version
|
||||
-> ByteString
|
||||
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
|
||||
|
||||
|
||||
-- | Extract the version part of the result of `ghcLinkDestination`.
|
||||
ghcLinkVersion :: MonadThrow m => ByteString -> m Version
|
||||
ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
|
||||
where
|
||||
parser = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
|
||||
verParser = many1' (notWord8 _slash) >>= \t ->
|
||||
case version $ E.decodeUtf8 $ B.pack t of
|
||||
Left e -> fail $ show e
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
-- e.g. ghc-8.6.5
|
||||
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => Version -> m ()
|
||||
rmMinorSymlinks ver = do
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
let myfiles =
|
||||
filter (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x) files
|
||||
forM_ myfiles $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
-- E.g. ghc, if this version is the set one.
|
||||
-- This reads `ghcupGHCDir`.
|
||||
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmPlain ver = do
|
||||
files <- liftE $ ghcToolFiles ver
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
forM_ files $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
-- old ghcup
|
||||
let hdc_file = (bindir </> [rel|haddock-ghc|])
|
||||
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
|
||||
|
||||
-- e.g. ghc-8.6
|
||||
rmMajorSymlinks :: (MonadLogger m, MonadIO m) => Version -> m ()
|
||||
rmMajorSymlinks ver = do
|
||||
(mj, mi) <- liftIO $ getGHCMajor ver
|
||||
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
|
||||
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
let myfiles = filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
|
||||
forM_ myfiles $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------------------------
|
||||
--[ Set/Installed introspection ]--
|
||||
-----------------------------------
|
||||
|
||||
|
||||
toolAlreadyInstalled :: Tool -> Version -> IO Bool
|
||||
toolAlreadyInstalled tool ver = case tool of
|
||||
GHC -> ghcInstalled ver
|
||||
Cabal -> cabalInstalled ver
|
||||
GHCup -> pure True
|
||||
|
||||
|
||||
ghcInstalled :: Version -> IO Bool
|
||||
ghcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesDirectoryExist ghcdir
|
||||
|
||||
|
||||
ghcSrcInstalled :: Version -> IO Bool
|
||||
ghcSrcInstalled ver = do
|
||||
ghcdir <- ghcupGHCDir ver
|
||||
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
||||
|
||||
|
||||
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
|
||||
ghcSet = do
|
||||
ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
|
||||
-- link destination is of the form ../ghc/<ver>/bin/ghc
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
link <- readSymbolicLink $ toFilePath ghcBin
|
||||
Just <$> ghcLinkVersion link
|
||||
|
||||
|
||||
cabalInstalled :: Version -> IO Bool
|
||||
cabalInstalled ver = do
|
||||
reportedVer <- cabalSet
|
||||
pure (reportedVer == ver)
|
||||
|
||||
cabalSet :: (MonadIO m, MonadThrow m) => m Version
|
||||
cabalSet = do
|
||||
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
mc <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
|
||||
case version (E.decodeUtf8 reportedVer) of
|
||||
Left e -> throwM e
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
|
||||
-----------------------------------------
|
||||
--[ Major version introspection (X.Y) ]--
|
||||
-----------------------------------------
|
||||
|
||||
|
||||
-- | We assume GHC is in semver format. I hope it is.
|
||||
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
|
||||
getGHCMajor ver = do
|
||||
SemVer {..} <- throwEither (semver $ prettyVer ver)
|
||||
pure (fromIntegral _svMajor, fromIntegral _svMinor)
|
||||
|
||||
|
||||
-- | Get the latest installed full GHC version that satisfies X.Y.
|
||||
-- This reads `ghcupGHCBaseDir`.
|
||||
getGHCForMajor :: (MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> m (Maybe Version)
|
||||
getGHCForMajor major' minor' = do
|
||||
p <- liftIO $ ghcupGHCBaseDir
|
||||
ghcs <- liftIO $ getDirsFiles' p
|
||||
semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
|
||||
mapM (throwEither . version)
|
||||
. fmap prettySemVer
|
||||
. lastMay
|
||||
. sort
|
||||
. filter
|
||||
(\SemVer {..} ->
|
||||
fromIntegral _svMajor == major' && fromIntegral _svMinor == minor'
|
||||
)
|
||||
$ semvers
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Unpacking ]--
|
||||
-----------------
|
||||
|
||||
|
||||
|
||||
-- | Unpack an archive to a temporary directory and return that path.
|
||||
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||
=> Path Abs -- ^ destination dir
|
||||
-> Path Abs -- ^ archive path
|
||||
-> Excepts '[UnknownArchive] m ()
|
||||
unpackToDir dest av = do
|
||||
let fp = E.decodeUtf8 (toFilePath av)
|
||||
lift $ $(logInfo) [i|Unpacking: #{fp}|]
|
||||
fn <- toFilePath <$> basename av
|
||||
let untar = Tar.unpack (toFilePath dest) . Tar.read
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . GZip.decompress =<< readFile av)
|
||||
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
|
||||
filecontents <- liftIO $ readFile av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftIO $ untar decompressed
|
||||
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . BZip.decompress =<< readFile av)
|
||||
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
|
||||
|
||||
|
||||
------------
|
||||
--[ Tags ]--
|
||||
------------
|
||||
|
||||
|
||||
-- | Get the tool versions that have this tag.
|
||||
getTagged :: GHCupDownloads -> Tool -> Tag -> [Version]
|
||||
getTagged av tool tag = toListOf
|
||||
( ix tool
|
||||
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
|
||||
% to Map.keys
|
||||
% folded
|
||||
)
|
||||
av
|
||||
|
||||
getLatest :: GHCupDownloads -> Tool -> Maybe Version
|
||||
getLatest av tool = headOf folded $ getTagged av tool Latest
|
||||
|
||||
getRecommended :: GHCupDownloads -> Tool -> Maybe Version
|
||||
getRecommended av tool = headOf folded $ getTagged av tool Recommended
|
||||
|
||||
|
||||
|
||||
-----------------------
|
||||
--[ Settings Getter ]--
|
||||
-----------------------
|
||||
|
||||
|
||||
getUrlSource :: MonadReader Settings m => m URLSource
|
||||
getUrlSource = ask <&> urlSource
|
||||
|
||||
getCache :: MonadReader Settings m => m Bool
|
||||
getCache = ask <&> cache
|
||||
|
||||
|
||||
|
||||
-------------
|
||||
--[ Other ]--
|
||||
-------------
|
||||
|
||||
|
||||
urlBaseName :: MonadThrow m
|
||||
=> ByteString -- ^ the url path (without scheme and host)
|
||||
-> m (Path Rel)
|
||||
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||
|
||||
|
||||
-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
|
||||
-- while ignoring *-<ver> symlinks.
|
||||
--
|
||||
-- Returns unversioned relative files, e.g.:
|
||||
-- ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
|
||||
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Version
|
||||
-> Excepts '[NotInstalled] m [Path Rel]
|
||||
ghcToolFiles ver = do
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
let bindir = ghcdir </> [rel|bin|]
|
||||
|
||||
-- fail if ghc is not installed
|
||||
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
|
||||
(throwE (NotInstalled GHC ver))
|
||||
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
-- figure out the <ver> suffix, because this might not be `Version` for
|
||||
-- alpha/rc releases, but x.y.a.somedate.
|
||||
(Just symver) <-
|
||||
(B.stripPrefix [s|ghc-|] . takeFileName)
|
||||
<$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> [rel|ghc|]))
|
||||
when (B.null symver)
|
||||
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
|
||||
|
||||
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
|
||||
|
||||
|
||||
-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
|
||||
-- this GHC was built from source. It contains the build config.
|
||||
ghcUpSrcBuiltFile :: Path Rel
|
||||
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
|
||||
69
lib/GHCup/Utils/Bash.hs
Normal file
69
lib/GHCup/Utils/Bash.hs
Normal file
@ -0,0 +1,69 @@
|
||||
module GHCup.Utils.Bash
|
||||
( findAssignment
|
||||
, equalsAssignmentWith
|
||||
, getRValue
|
||||
, getAssignmentValueFor
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Data.ByteString.UTF8 ( toString )
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Language.Bash.Parse
|
||||
import Language.Bash.Syntax
|
||||
import Language.Bash.Word
|
||||
import Prelude hiding ( readFile )
|
||||
|
||||
import qualified Data.ByteString.Lazy.UTF8 as UTF8
|
||||
|
||||
|
||||
extractAssignments :: List -> [Assign]
|
||||
extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
|
||||
where
|
||||
getCommands :: [Statement] -> [Command]
|
||||
getCommands = join . fmap commands . catMaybes . fmap findPipes
|
||||
where
|
||||
findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
|
||||
findPipes _ = Nothing
|
||||
|
||||
getAssign :: Command -> [Assign]
|
||||
getAssign (Command (SimpleCommand ass _) _) = ass
|
||||
getAssign _ = []
|
||||
|
||||
|
||||
-- | Find an assignment matching the predicate in the given file.
|
||||
findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
|
||||
findAssignment p predicate = do
|
||||
fileContents <- readFile p
|
||||
-- TODO: this should accept bytestring:
|
||||
-- https://github.com/knrafto/language-bash/issues/37
|
||||
case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
|
||||
Left e -> fail $ show e
|
||||
Right l -> pure $ find predicate (extractAssignments $ l)
|
||||
|
||||
|
||||
-- | Check that the assignment is of the form Foo= ignoring the
|
||||
-- right hand-side.
|
||||
equalsAssignmentWith :: String -> Assign -> Bool
|
||||
equalsAssignmentWith n ass = case ass of
|
||||
(Assign (Parameter name' Nothing) Equals _) -> n == name'
|
||||
_ -> False
|
||||
|
||||
|
||||
-- | This pretty-prints the right hand of an Equals assignment, removing
|
||||
-- quotations. No evaluation is performed.
|
||||
getRValue :: Assign -> Maybe String
|
||||
getRValue ass = case ass of
|
||||
(Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
-- | Given a bash assignment such as Foo="Bar" in the given file,
|
||||
-- will return "Bar" (without quotations).
|
||||
getAssignmentValueFor :: Path b -> String -> IO (Maybe String)
|
||||
getAssignmentValueFor p n = do
|
||||
mass <- findAssignment p (equalsAssignmentWith n)
|
||||
pure (mass >>= getRValue)
|
||||
91
lib/GHCup/Utils/Dirs.hs
Normal file
91
lib/GHCup/Utils/Dirs.hs
Normal file
@ -0,0 +1,91 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module GHCup.Utils.Dirs where
|
||||
|
||||
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Maybe
|
||||
import Data.Versions
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.Posix.Env.ByteString ( getEnv
|
||||
, getEnvDefault
|
||||
)
|
||||
import System.Posix.Temp.ByteString ( mkdtemp )
|
||||
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified System.Posix.FilePath as FP
|
||||
import qualified System.Posix.User as PU
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ GHCup directories ]--
|
||||
-------------------------
|
||||
|
||||
|
||||
ghcupBaseDir :: IO (Path Abs)
|
||||
ghcupBaseDir = do
|
||||
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> ([rel|.ghcup|] :: Path Rel))
|
||||
|
||||
ghcupGHCBaseDir :: IO (Path Abs)
|
||||
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
|
||||
|
||||
ghcupGHCDir :: Version -> IO (Path Abs)
|
||||
ghcupGHCDir ver = do
|
||||
ghcbasedir <- ghcupGHCBaseDir
|
||||
verdir <- parseRel (verToBS ver)
|
||||
pure (ghcbasedir </> verdir)
|
||||
|
||||
|
||||
ghcupBinDir :: IO (Path Abs)
|
||||
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
|
||||
|
||||
ghcupCacheDir :: IO (Path Abs)
|
||||
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
|
||||
|
||||
ghcupLogsDir :: IO (Path Abs)
|
||||
ghcupLogsDir = ghcupBaseDir <&> (</> ([rel|logs|] :: Path Rel))
|
||||
|
||||
|
||||
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
mkGhcupTmpDir = do
|
||||
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
|
||||
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
|
||||
parseAbs tmp
|
||||
|
||||
|
||||
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
|
||||
|
||||
|
||||
--------------
|
||||
--[ Others ]--
|
||||
--------------
|
||||
|
||||
|
||||
getHomeDirectory :: IO (Path Abs)
|
||||
getHomeDirectory = do
|
||||
e <- getEnv [s|HOME|]
|
||||
case e of
|
||||
Just fp -> parseAbs fp
|
||||
Nothing -> do
|
||||
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
|
||||
parseAbs $ UTF8.fromString h -- this is a guess
|
||||
246
lib/GHCup/Utils/File.hs
Normal file
246
lib/GHCup/Utils/File.hs
Normal file
@ -0,0 +1,246 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GHCup.Utils.File where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Data.ByteString
|
||||
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
|
||||
import Data.Char
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import GHC.Foreign ( peekCStringLen )
|
||||
import GHC.IO.Encoding ( getLocaleEncoding )
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Optics
|
||||
import Streamly
|
||||
import Streamly.External.ByteString
|
||||
import Streamly.External.ByteString.Lazy
|
||||
import System.IO
|
||||
import System.Posix.Directory.ByteString
|
||||
import System.Posix.FD as FD
|
||||
import System.Posix.FilePath hiding ( (</>) )
|
||||
import System.Posix.Foreign ( oExcl )
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( openFd )
|
||||
import System.Posix.Process ( ProcessStatus(..) )
|
||||
import System.Posix.Types
|
||||
|
||||
|
||||
import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
import Streamly.External.Posix.DirStream
|
||||
import qualified Streamly.Internal.Memory.ArrayStream
|
||||
as AS
|
||||
import qualified Streamly.FileSystem.Handle as FH
|
||||
import qualified Streamly.Internal.Data.Unfold as SU
|
||||
import qualified Streamly.Prelude as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
|
||||
data ProcessError = NonZeroExit Int ByteString [ByteString]
|
||||
| PTerminated ByteString [ByteString]
|
||||
| PStopped ByteString [ByteString]
|
||||
| NoSuchPid ByteString [ByteString]
|
||||
deriving Show
|
||||
|
||||
|
||||
data CapturedProcess = CapturedProcess
|
||||
{ _exitCode :: ExitCode
|
||||
, _stdOut :: ByteString
|
||||
, _stdErr :: ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
makeLenses ''CapturedProcess
|
||||
|
||||
|
||||
readFd :: Fd -> IO L.ByteString
|
||||
readFd fd = do
|
||||
handle' <- fdToHandle fd
|
||||
fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
|
||||
|
||||
|
||||
-- | Read the lines of a file into a stream. The stream holds
|
||||
-- a file handle as a resource and will close it once the stream
|
||||
-- terminates (either through exception or because it's drained).
|
||||
readFileLines :: Path b -> IO (SerialT IO ByteString)
|
||||
readFileLines p = do
|
||||
stream <- readFileStream p
|
||||
pure
|
||||
. (fmap fromArray)
|
||||
. AS.splitOn (fromIntegral $ ord '\n')
|
||||
. (fmap toArray)
|
||||
$ stream
|
||||
|
||||
|
||||
-- | Find the given executable by searching all *absolute* PATH components.
|
||||
-- Relative paths in PATH are ignored.
|
||||
--
|
||||
-- This shouldn't throw IO exceptions, unless getting the environment variable
|
||||
-- PATH does.
|
||||
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
|
||||
findExecutable ex = do
|
||||
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
|
||||
-- We don't want exceptions to mess up our result. If we can't
|
||||
-- figure out if a file exists, then treat it as a negative result.
|
||||
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
|
||||
-- asum for short-circuiting behavior
|
||||
(\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
|
||||
sPaths
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
||||
-- The command is run in a subprocess.
|
||||
executeOut :: Path b -- ^ command as filename, e.g. 'ls'
|
||||
-> [ByteString] -- ^ arguments to the command
|
||||
-> Maybe (Path Abs) -- ^ chdir to this path
|
||||
-> IO CapturedProcess
|
||||
executeOut path args chdir = captureOutStreams $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile (toFilePath path) True args Nothing
|
||||
|
||||
|
||||
execLogged :: ByteString -- ^ thing to execute
|
||||
-> Bool -- ^ whether to search PATH for the thing
|
||||
-> [ByteString] -- ^ args for the thing
|
||||
-> Path Rel -- ^ log filename
|
||||
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||
-> IO (Either ProcessError ())
|
||||
execLogged exe spath args lfile chdir env = do
|
||||
ldir <- ghcupLogsDir
|
||||
let logfile = ldir </> lfile
|
||||
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
|
||||
where
|
||||
action fd = do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
-- dup stdout
|
||||
void $ dupTo fd stdOutput
|
||||
|
||||
-- dup stderr
|
||||
void $ dupTo fd stdError
|
||||
|
||||
-- execute the action
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile exe spath args env
|
||||
|
||||
|
||||
SPPB.getProcessStatus True True pid >>= \case
|
||||
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
|
||||
i -> pure $ toProcessError exe args i
|
||||
|
||||
|
||||
-- | Capture the stdout and stderr of the given action, which
|
||||
-- is run in a subprocess. Stdin is closed. You might want to
|
||||
-- 'race' this to make sure it terminates.
|
||||
captureOutStreams :: IO a
|
||||
-- ^ the action to execute in a subprocess
|
||||
-> IO CapturedProcess
|
||||
captureOutStreams action =
|
||||
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
|
||||
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
-- dup stdout
|
||||
void $ dupTo childStdoutWrite stdOutput
|
||||
closeFd childStdoutWrite
|
||||
closeFd parentStdoutRead
|
||||
|
||||
-- dup stderr
|
||||
void $ dupTo childStderrWrite stdError
|
||||
closeFd childStderrWrite
|
||||
closeFd parentStderrRead
|
||||
|
||||
-- execute the action
|
||||
void $ action
|
||||
|
||||
-- close everything we don't need
|
||||
closeFd childStdoutWrite
|
||||
closeFd childStderrWrite
|
||||
|
||||
SPPB.getProcessStatus True True pid >>= \case
|
||||
-- readFd will take care of closing the fd
|
||||
Just (SPPB.Exited es) -> do
|
||||
stdout' <- L.toStrict <$> readFd parentStdoutRead
|
||||
stderr' <- L.toStrict <$> readFd parentStderrRead
|
||||
pure $ CapturedProcess { _exitCode = es
|
||||
, _stdOut = stdout'
|
||||
, _stdErr = stderr'
|
||||
}
|
||||
_ -> throwIO $ userError $ ("No such PID " ++ show pid)
|
||||
|
||||
where
|
||||
actionWithPipes a =
|
||||
createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
|
||||
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
|
||||
|
||||
|
||||
|
||||
-- | Create a new regular file in write-only mode. The file must not exist.
|
||||
createRegularFileFd :: FileMode -> Path b -> IO Fd
|
||||
createRegularFileFd fm dest =
|
||||
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: ByteString -- ^ thing to execute
|
||||
-> Bool -- ^ whether to search PATH for the thing
|
||||
-> [ByteString] -- ^ args for the thing
|
||||
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||
-> IO (Either ProcessError ())
|
||||
exec exe spath args chdir env = do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile exe spath args env
|
||||
|
||||
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
|
||||
|
||||
|
||||
toProcessError :: ByteString
|
||||
-> [ByteString]
|
||||
-> Maybe ProcessStatus
|
||||
-> Either ProcessError ()
|
||||
toProcessError exe args mps = case mps of
|
||||
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
|
||||
Just (SPPB.Exited ExitSuccess ) -> Right ()
|
||||
Just (Terminated _ _ ) -> Left $ PTerminated exe args
|
||||
Just (Stopped _ ) -> Left $ PStopped exe args
|
||||
Nothing -> Left $ NoSuchPid exe args
|
||||
|
||||
|
||||
-- | Convert the String to a ByteString with the current
|
||||
-- system encoding.
|
||||
unsafePathToString :: Path b -> IO FilePath
|
||||
unsafePathToString p = do
|
||||
enc <- getLocaleEncoding
|
||||
unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
|
||||
|
||||
|
||||
-- | Search for a file in the search paths.
|
||||
--
|
||||
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
|
||||
searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
|
||||
searchPath paths needle = go paths
|
||||
where
|
||||
go [] = pure Nothing
|
||||
go (x : xs) =
|
||||
hideErrorDefM PermissionDenied (go xs)
|
||||
$ hideErrorDefM NoSuchThing (go xs)
|
||||
$ do
|
||||
dirStream <- openDirStream (toFilePath x)
|
||||
S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
|
||||
>>= \case
|
||||
Just _ -> pure $ Just (x </> needle)
|
||||
Nothing -> go xs
|
||||
isMatch basedir p = do
|
||||
if p == toFilePath needle
|
||||
then isExecutable (basedir </> needle)
|
||||
else pure False
|
||||
60
lib/GHCup/Utils/Logger.hs
Normal file
60
lib/GHCup/Utils/Logger.hs
Normal file
@ -0,0 +1,60 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module GHCup.Utils.Logger where
|
||||
|
||||
import GHCup.Utils
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Console.Pretty
|
||||
import System.IO.Error
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
|
||||
|
||||
data LoggerConfig = LoggerConfig
|
||||
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
|
||||
, colorOutter :: B.ByteString -> IO () -- ^ how to write the color output
|
||||
, rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output
|
||||
}
|
||||
|
||||
|
||||
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
|
||||
myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
|
||||
where
|
||||
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
|
||||
mylogger _ _ level str' = do
|
||||
-- color output
|
||||
let l = case level of
|
||||
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")
|
||||
|
||||
when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
|
||||
$ colorOutter out
|
||||
|
||||
-- raw output
|
||||
let lr = case level of
|
||||
LevelDebug -> toLogStr "Debug: "
|
||||
LevelInfo -> toLogStr "Info:"
|
||||
LevelWarn -> toLogStr "Warn:"
|
||||
LevelError -> toLogStr "Error:"
|
||||
LevelOther t -> toLogStr t <> toLogStr ":"
|
||||
let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
|
||||
rawOutter outr
|
||||
|
||||
|
||||
initGHCupFileLogging :: Path Rel -> IO (Path Abs)
|
||||
initGHCupFileLogging context = do
|
||||
logs <- ghcupLogsDir
|
||||
let logfile = logs </> context
|
||||
createDirIfMissing newDirPerms logs
|
||||
hideError doesNotExistErrorType $ deleteFile logfile
|
||||
createRegularFile newFilePerms logfile
|
||||
pure logfile
|
||||
243
lib/GHCup/Utils/Prelude.hs
Normal file
243
lib/GHCup/Utils/Prelude.hs
Normal file
@ -0,0 +1,243 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module GHCup.Utils.Prelude where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Monoid ( (<>) )
|
||||
import Data.String
|
||||
import Data.Text ( Text )
|
||||
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
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as B
|
||||
import qualified Data.Text.Lazy.Builder.Int as B
|
||||
import qualified Data.Text.Lazy.Encoding as TLE
|
||||
|
||||
|
||||
|
||||
fS :: IsString a => String -> a
|
||||
fS = fromString
|
||||
|
||||
fromStrictMaybe :: S.Maybe a -> Maybe a
|
||||
fromStrictMaybe = S.maybe Nothing Just
|
||||
|
||||
fSM :: S.Maybe a -> Maybe a
|
||||
fSM = fromStrictMaybe
|
||||
|
||||
toStrictMaybe :: Maybe a -> S.Maybe a
|
||||
toStrictMaybe = maybe S.Nothing S.Just
|
||||
|
||||
tSM :: Maybe a -> S.Maybe a
|
||||
tSM = toStrictMaybe
|
||||
|
||||
internalError :: String -> IO a
|
||||
internalError = fail . ("Internal error: " <>)
|
||||
|
||||
iE :: String -> IO a
|
||||
iE = internalError
|
||||
|
||||
|
||||
showT :: Show a => a -> Text
|
||||
showT = fS . show
|
||||
|
||||
-- | Like 'when', but where the test can be monadic.
|
||||
whenM :: Monad m => m Bool -> m () -> m ()
|
||||
whenM ~b ~t = ifM b t (return ())
|
||||
|
||||
-- | Like 'unless', but where the test can be monadic.
|
||||
unlessM :: Monad m => m Bool -> m () -> m ()
|
||||
unlessM ~b ~f = ifM b (return ()) f
|
||||
|
||||
-- | Like @if@, but where the test can be monadic.
|
||||
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
||||
ifM ~b ~t ~f = do
|
||||
b' <- b
|
||||
if b' then t else f
|
||||
|
||||
whileM :: Monad m => m a -> (a -> m Bool) -> m a
|
||||
whileM ~action ~f = do
|
||||
a <- action
|
||||
b' <- f a
|
||||
if b' then whileM action f else pure a
|
||||
|
||||
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
|
||||
whileM_ ~action = void . whileM action
|
||||
|
||||
guardM :: (Monad m, Alternative m) => m Bool -> m ()
|
||||
guardM ~f = guard =<< f
|
||||
|
||||
lBS2sT :: L.ByteString -> Text
|
||||
lBS2sT = TL.toStrict . TLE.decodeUtf8
|
||||
|
||||
|
||||
|
||||
handleIO' :: (MonadIO m, MonadCatch m)
|
||||
=> IOErrorType
|
||||
-> (IOException -> m a)
|
||||
-> m a
|
||||
-> m a
|
||||
handleIO' err handler = handleIO
|
||||
(\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)
|
||||
|
||||
|
||||
(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
|
||||
(??) m e = maybe (throwE e) pure m
|
||||
|
||||
|
||||
(!?) :: forall e es a m
|
||||
. (Monad m, e :< es)
|
||||
=> m (Maybe a)
|
||||
-> e
|
||||
-> Excepts es m a
|
||||
(!?) em e = lift em >>= (?? e)
|
||||
|
||||
|
||||
lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
|
||||
lE = liftE . veitherToExcepts . fromEither
|
||||
|
||||
lE' :: forall e' e es a m
|
||||
. (Monad m, e :< es)
|
||||
=> (e' -> e)
|
||||
-> Either e' a
|
||||
-> Excepts es m a
|
||||
lE' f = liftE . veitherToExcepts . fromEither . bimap f id
|
||||
|
||||
lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
|
||||
lEM em = lift em >>= lE
|
||||
|
||||
lEM' :: forall e' e es a m
|
||||
. (Monad m, e :< es)
|
||||
=> (e' -> e)
|
||||
-> m (Either e' a)
|
||||
-> Excepts es m a
|
||||
lEM' f em = lift em >>= lE . bimap f id
|
||||
|
||||
fromEither :: Either a b -> VEither '[a] b
|
||||
fromEither = either (VLeft . V) VRight
|
||||
|
||||
|
||||
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
|
||||
)
|
||||
. 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)
|
||||
|
||||
|
||||
hideErrorDefM :: IOErrorType -> IO a -> IO a -> IO a
|
||||
hideErrorDefM err def =
|
||||
handleIO (\e -> if err == ioeGetErrorType e then def else ioError e)
|
||||
|
||||
|
||||
-- TODO: does this work?
|
||||
hideExcept :: forall e es es' a m
|
||||
. (Monad m, e :< es, LiftVariant (Remove e es) es')
|
||||
=> e
|
||||
-> a
|
||||
-> Excepts es m a
|
||||
-> Excepts es' m a
|
||||
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
|
||||
-> Excepts es m ()
|
||||
-> Excepts es' m ()
|
||||
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
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
verToBS :: Version -> ByteString
|
||||
verToBS = E.encodeUtf8 . prettyVer
|
||||
|
||||
|
||||
intToText :: Integral a => a -> T.Text
|
||||
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)
|
||||
48
lib/GHCup/Utils/String/QQ.hs
Normal file
48
lib/GHCup/Utils/String/QQ.hs
Normal file
@ -0,0 +1,48 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
|
||||
--
|
||||
-- The "s" quoter contains a multi-line string with no interpolation at all,
|
||||
-- except that the leading newline is trimmed and carriage returns stripped.
|
||||
--
|
||||
-- @
|
||||
-- {-\# LANGUAGE QuasiQuotes #-}
|
||||
-- import Data.Text (Text)
|
||||
-- import Data.String.QQ
|
||||
-- foo :: Text -- "String", "ByteString" etc also works
|
||||
-- foo = [s|
|
||||
-- Well here is a
|
||||
-- multi-line string!
|
||||
-- |]
|
||||
-- @
|
||||
--
|
||||
-- Any instance of the IsString type is permitted.
|
||||
--
|
||||
-- (For GHC versions 6, write "[$s||]" instead of "[s||]".)
|
||||
--
|
||||
module GHCup.Utils.String.QQ
|
||||
( s
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
import Data.Char
|
||||
import GHC.Exts ( IsString(..) )
|
||||
import Language.Haskell.TH.Quote
|
||||
|
||||
-- | QuasiQuoter for a non-interpolating ASCII IsString literal.
|
||||
-- The pattern portion is undefined.
|
||||
s :: QuasiQuoter
|
||||
s = QuasiQuoter
|
||||
(\s' -> case and $ fmap isAscii s' of
|
||||
True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
|
||||
False -> fail "Not ascii"
|
||||
)
|
||||
(error "Cannot use q as a pattern")
|
||||
(error "Cannot use q as a type")
|
||||
(error "Cannot use q as a dec")
|
||||
where
|
||||
removeCRs = filter (/= '\r')
|
||||
trimLeadingNewline ('\n' : xs) = xs
|
||||
trimLeadingNewline xs = xs
|
||||
|
||||
89
lib/GHCup/Utils/Version/QQ.hs
Normal file
89
lib/GHCup/Utils/Version/QQ.hs
Normal file
@ -0,0 +1,89 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
module GHCup.Utils.Version.QQ where
|
||||
|
||||
import Data.Data
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import GHC.Base
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
|
||||
import Language.Haskell.TH.Syntax ( Exp(..)
|
||||
, Lift
|
||||
, dataToExpQ
|
||||
)
|
||||
import qualified Data.Text as T
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
|
||||
|
||||
|
||||
deriving instance Data Versioning
|
||||
deriving instance Lift Versioning
|
||||
deriving instance Data Version
|
||||
deriving instance Lift Version
|
||||
deriving instance Data SemVer
|
||||
deriving instance Lift SemVer
|
||||
deriving instance Data Mess
|
||||
deriving instance Lift Mess
|
||||
deriving instance Data PVP
|
||||
deriving instance Lift PVP
|
||||
deriving instance Lift (NonEmpty Word)
|
||||
deriving instance Lift VSep
|
||||
deriving instance Data VSep
|
||||
deriving instance Lift VUnit
|
||||
deriving instance Data VUnit
|
||||
instance Lift Text
|
||||
|
||||
qq :: (Text -> Q Exp) -> QuasiQuoter
|
||||
qq quoteExp' = QuasiQuoter
|
||||
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
|
||||
, quotePat = \_ ->
|
||||
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
|
||||
, quoteType = \_ ->
|
||||
fail "illegal QuasiQuote (allowed as expression only, used as a type)"
|
||||
, quoteDec = \_ -> fail
|
||||
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
|
||||
}
|
||||
|
||||
vver :: QuasiQuoter
|
||||
vver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) liftDataWithText . version
|
||||
|
||||
mver :: QuasiQuoter
|
||||
mver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) liftDataWithText . mess
|
||||
|
||||
sver :: QuasiQuoter
|
||||
sver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) liftDataWithText . semver
|
||||
|
||||
vers :: QuasiQuoter
|
||||
vers = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) liftDataWithText . versioning
|
||||
|
||||
pver :: QuasiQuoter
|
||||
pver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) liftDataWithText . pvp
|
||||
|
||||
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
|
||||
liftText :: T.Text -> Q Exp
|
||||
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
|
||||
|
||||
liftDataWithText :: Data a => a -> Q Exp
|
||||
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)
|
||||
11
lib/GHCup/Version.hs
Normal file
11
lib/GHCup/Version.hs
Normal file
@ -0,0 +1,11 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
|
||||
module GHCup.Version where
|
||||
|
||||
import GHCup.Utils.Version.QQ
|
||||
|
||||
import Data.Versions
|
||||
|
||||
ghcUpVer :: PVP
|
||||
ghcUpVer = [pver|0.1.0|]
|
||||
4
test/MyLibTest.hs
Normal file
4
test/MyLibTest.hs
Normal file
@ -0,0 +1,4 @@
|
||||
module Main (main) where
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Test suite not yet implemented."
|
||||
66
update-index-state.sh
Executable file
66
update-index-state.sh
Executable file
@ -0,0 +1,66 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
set -eu
|
||||
|
||||
status_message() {
|
||||
printf "\\033[0;32m%s\\033[0m\\n" "$1"
|
||||
}
|
||||
|
||||
error_message() {
|
||||
printf "\\033[0;31m%s\\033[0m\\n" "$1"
|
||||
}
|
||||
|
||||
SCRIPTPATH="$( cd "$(dirname "$0")" ; pwd -P )"
|
||||
CACHE_LOCATION="${HOME}/.cabal/packages/hackage.haskell.org/01-index.cache"
|
||||
|
||||
if [ ! -f "${CACHE_LOCATION}" ] ; then
|
||||
error_message "${CACHE_LOCATION} does not exist, did you run 'cabal update'?"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
if [ ! -f "${SCRIPTPATH}/cabal.project" ] ; then
|
||||
error_message "Could not find ${SCRIPTPATH}/cabal.project, skipping index state update."
|
||||
exit 3
|
||||
fi
|
||||
|
||||
cabal v2-update
|
||||
|
||||
arch=$(getconf LONG_BIT)
|
||||
|
||||
case "${arch}" in
|
||||
32)
|
||||
byte_size=4
|
||||
magic_word="CABA1002"
|
||||
;;
|
||||
64)
|
||||
byte_size=8
|
||||
magic_word="00000000CABA1002"
|
||||
;;
|
||||
*)
|
||||
error_message "Unknown architecture (long bit): ${arch}"
|
||||
exit 2
|
||||
;;
|
||||
esac
|
||||
|
||||
# This is the logic to parse the binary format of 01-index.cache.
|
||||
# The first word is a magic 'caba1002', the second one is the timestamp in unix epoch.
|
||||
# Better than copying the cabal-install source code.
|
||||
if [ "$(xxd -u -p -l${byte_size} -s 0 "${CACHE_LOCATION}")" != "${magic_word}" ] ; then
|
||||
error_message "Magic word does not match!"
|
||||
exit 4
|
||||
fi
|
||||
cache_timestamp=$(echo "ibase=16;obase=A;$(xxd -u -p -l${byte_size} -s ${byte_size} "${CACHE_LOCATION}")" | bc)
|
||||
|
||||
# If we got junk from the binary file, this should fail.
|
||||
cache_date=$(date --utc --date "@${cache_timestamp}" "+%FT%TZ")
|
||||
|
||||
|
||||
status_message "Updating index state in ${SCRIPTPATH}/cabal.project"
|
||||
|
||||
if grep -q "^index-state: .*" "${SCRIPTPATH}/cabal.project" ; then
|
||||
awk '/index-state:/ {gsub(/.*/, "index-state: '${cache_date}'")}; { print }' "${SCRIPTPATH}/cabal.project" > "${SCRIPTPATH}/cabal.project.tmp"
|
||||
mv "${SCRIPTPATH}/cabal.project.tmp" "${SCRIPTPATH}/cabal.project"
|
||||
else
|
||||
printf "index-state: %s\n" "${cache_date}" >> "${SCRIPTPATH}/cabal.project"
|
||||
fi
|
||||
|
||||
Loading…
Reference in New Issue
Block a user