Compare commits
78 Commits
a93aaf9a5f
...
v0.1.1
| Author | SHA1 | Date | |
|---|---|---|---|
| 883226aa70 | |||
| 0d393612a7 | |||
| 5635f6cc4e | |||
| a7fd36beeb | |||
| baee1d5b85 | |||
| 68df6b8e50 | |||
| ac73090784 | |||
| faf4f3b7ca | |||
| d888d11d59 | |||
| 28a1077833 | |||
| c40b9dbc0b | |||
| 6bbd262818 | |||
| 78d36bce24 | |||
| aedfc19220 | |||
| 2f34fc7bef | |||
| de66b92631 | |||
| fee3984bf7 | |||
| b953c8fd30 | |||
| 24e4c3a19b | |||
| d2efb504b9 | |||
| df9dd0e785 | |||
| 89c9699158 | |||
| 124ddcdfeb | |||
| 5c0a0fc155 | |||
| b11b74d2b4 | |||
| 5ac8f5b651 | |||
| 9032df97cf | |||
| 14e1077ad1 | |||
| b5648bdd6b | |||
| e7cd952970 | |||
| 1455c2c175 | |||
| c106dd3f65 | |||
| f6725fbf5f | |||
| c706a047ea | |||
| 9602db31ab | |||
| c2c47e1b7e | |||
| 34386680cc | |||
| 16a26d9881 | |||
| 3496f24f6e | |||
| 1a5876a074 | |||
| c782bc44de | |||
| f78e7b1cbc | |||
| adec7b2398 | |||
| 958bf698b9 | |||
| 6a79782650 | |||
| 5382fd9aca | |||
| 8a0236a350 | |||
| 3e52def226 | |||
| 5d3c26b509 | |||
| 99941bc2a1 | |||
| 63f290107c | |||
| 31a8316bfa | |||
| 3ff6be5435 | |||
| 0963081fd8 | |||
| af42598a27 | |||
| e6037b9eb5 | |||
| e58e1c1954 | |||
| c7a831a280 | |||
| e77ed1a26c | |||
| c0c70f5c9b | |||
| fee16758de | |||
| f8448cf02b | |||
| 35b6359c1b | |||
| 9c7d17800d | |||
| ee570c024c | |||
| fcb7129251 | |||
| 8a1bd45ffe | |||
| f5a2db6719 | |||
| 2c99070d89 | |||
| 93aac16fc5 | |||
| 775c541895 | |||
| b0eba1a77a | |||
| 8aa2be5898 | |||
| 951a7173ae | |||
| b7f49b1c94 | |||
| dcd6812fb7 | |||
| 167826dfce | |||
| 03ee8915fb |
1
.gitignore
vendored
1
.gitignore
vendored
@@ -1 +1,2 @@
|
||||
dist-newstyle/
|
||||
.stack-work/
|
||||
|
||||
25
.travis.yml
Normal file
25
.travis.yml
Normal file
@@ -0,0 +1,25 @@
|
||||
jobs:
|
||||
include:
|
||||
- os: osx
|
||||
osx_image: xcode10.1
|
||||
language: generic
|
||||
env: ARTIFACT=x86_64-apple-darwin-10.13-ghcup
|
||||
|
||||
- os: osx
|
||||
osx_image: xcode11.3
|
||||
language: generic
|
||||
env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
|
||||
|
||||
script: ".travis/build.sh"
|
||||
|
||||
deploy:
|
||||
provider: releases
|
||||
api_key:
|
||||
secure: GQESg4TcYf3PQJRRaZV/kWS0hsF+OFnH2+EcwpgnIcfx4+aogMyprdh745KtBXe1FlFN1luKHksFjqceqhcg/xcNyeCJiSnLWMn4D/i4WUperEHseRBi5yZZCB1AvOjIlHrE4DS3a8pyEm1GV3G7CKY5Fu8jBjof2SnyENfd7fofhjtNHWmeFS+jBn8HRDf1YaSRYxzTw6uHLrPLsybfgQZVl7babMu/38Ghin0f5pz5OlNokzDxaubIYQHOZ7st7YndHJtBWWql/KualBWbMILy88dUVQBnbqQLP2P8d1ME8ILUjJVqz33HiRU0JzlEJyWfbvEjcJ6iD8M6n4nXTaxfu3i2UhhGsQ6SSBNKssMP4tji8nkNpMqG59wLQ/zhcetEm71fKkgJNrIMNllkqlWSo5K74IqqP9kiLg/qm8ipOJjui0gPk8tZXKcV+ztX1d1OVCapoLfiDM5l/0LLQXaTOXOV1x3e5LLQ/w2doNiH3eh5CV4II9dRu7owpaiiMBHMssmT0pH99jEeF6giHLKtt3y7l2GWoRLPdhsZZ54gxsaBxZt9GuypmkbNcr97CEnAVaWij5v0CF3w4rAWqy/tAxQpIDJOIOQBgmwG5WrBAKyKrFvEpBL5a8BPcRWJDvqKC83QeWpvPrEVdgJevC6ZN1MKzrb2SiPOwC2Kerc=
|
||||
file: $ARTIFACT
|
||||
on:
|
||||
repo: haskell/ghcup-hs
|
||||
tags: true
|
||||
skip_cleanup: true
|
||||
draft: true
|
||||
|
||||
22
.travis/build.sh
Executable file
22
.travis/build.sh
Executable file
@@ -0,0 +1,22 @@
|
||||
#/bin/sh
|
||||
|
||||
set -ex
|
||||
|
||||
## install ghc via old ghcup
|
||||
|
||||
mkdir -p ~/.ghcup/bin
|
||||
curl https://gitlab.haskell.org/haskell/ghcup/raw/master/ghcup > ~/.ghcup/bin/ghcup
|
||||
chmod +x ~/.ghcup/bin/ghcup
|
||||
|
||||
export PATH="$HOME/.ghcup/bin:$PATH"
|
||||
|
||||
ghcup install 8.8.3
|
||||
ghcup install-cabal 3.2.0.0
|
||||
ghcup set 8.8.3
|
||||
|
||||
|
||||
## install ghcup
|
||||
|
||||
cabal update
|
||||
cabal build -fcurl
|
||||
cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" "./${ARTIFACT}"
|
||||
@@ -1,5 +1,9 @@
|
||||
# Revision history for ghcup
|
||||
|
||||
## 0.1.0.0 -- YYYY-mm-dd
|
||||
## 0.1.1 -- 2020-04-15
|
||||
|
||||
* fix awful fdopendir bug on mac bug by updating hpath-posix
|
||||
|
||||
## 0.1.0
|
||||
|
||||
* First version. Released on an unsuspecting world.
|
||||
|
||||
42
Dockerfile
Normal file
42
Dockerfile
Normal file
@@ -0,0 +1,42 @@
|
||||
FROM alpine:edge
|
||||
|
||||
# ghc and cabal
|
||||
RUN apk add --no-cache \
|
||||
curl \
|
||||
gcc \
|
||||
g++ \
|
||||
gmp-dev \
|
||||
ncurses-dev \
|
||||
libffi-dev \
|
||||
make \
|
||||
xz \
|
||||
tar \
|
||||
perl \
|
||||
\
|
||||
cabal \
|
||||
ghc
|
||||
|
||||
# utils
|
||||
RUN apk add --no-cache \
|
||||
bash
|
||||
|
||||
## Package specific
|
||||
RUN apk add --no-cache \
|
||||
zlib \
|
||||
zlib-dev \
|
||||
zlib-static \
|
||||
gmp \
|
||||
gmp-dev \
|
||||
openssl-dev \
|
||||
openssl-libs-static \
|
||||
xz \
|
||||
xz-dev
|
||||
|
||||
RUN cabal v2-update
|
||||
|
||||
COPY . /app
|
||||
|
||||
WORKDIR /app
|
||||
|
||||
RUN chmod +x /app/docker/build.sh
|
||||
|
||||
45
HACKING.md
Normal file
45
HACKING.md
Normal file
@@ -0,0 +1,45 @@
|
||||
# HACKING
|
||||
|
||||
## Design decisions
|
||||
|
||||
### Using [Excepts](https://hackage.haskell.org/package/haskus-utils-variant-3.0/docs/Haskus-Utils-Variant-Excepts.html) as a beefed up ExceptT
|
||||
|
||||
This is an open variant, similar to [plucky](https://hackage.haskell.org/package/plucky) or [oops](https://github.com/i-am-tom/oops) and allows us to combine different error types. Maybe it is too much and it's a little bit [unergonomic](https://github.com/haskus/packages/issues/32) at times. If it really hurts maintenance, it will be removed. It was more of an experiment.
|
||||
|
||||
### No use of filepath or directory
|
||||
|
||||
Filepath and directory have two fundamental problems: 1. they use String as filepath (see [AFPP](https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/abstract-file-path) as to why this is wrong) and 2. they try very hard to be cross-platform at the expense of low-level correctness. Instead, we use the [hpath](https://github.com/hasufell/hpath) libraries for file and filepath related stuff, which also gives us stronger filepath types.
|
||||
|
||||
### No use of haskell-TLS
|
||||
|
||||
I consider haskell-TLS an interesting experiment, but not a battle-tested and peer-reviewed crypto implementation. There is little to no research about what the intricacies of using haskell for low-level crypto are and how vulnerable such binaries are. Instead, we use either curl the binary (for FreeBSD and mac) or http-io-streams, which works with OpenSSL bindings.
|
||||
|
||||
### Optics instead of lens
|
||||
|
||||
They're a little safer (less Monoid weirdness with view) and have better error messages. Consider the following wit lens
|
||||
|
||||
```
|
||||
> view (_Just . to (++ "abc")) Nothing
|
||||
""
|
||||
```
|
||||
|
||||
vs optics
|
||||
|
||||
```
|
||||
> view (_Just % to (++ "abc")) Nothing
|
||||
|
||||
<interactive>:2:1: error:
|
||||
• An_AffineFold cannot be used as A_Getter
|
||||
• In the expression: view (_Just % to (++ "abc")) Nothing
|
||||
In an equation for ‘it’: it = view (_Just % to (++ "abc")) Nothing
|
||||
```
|
||||
|
||||
### Strict and StrictData on by default
|
||||
|
||||
Kazu Yamamoto [explained it in his PR](https://github.com/yesodweb/wai/pull/752#issuecomment-501531386) very well. I like to agree with him. The instances where we need non-strict behavior, we annotate it.
|
||||
|
||||
## Code style and formatting
|
||||
|
||||
1. Brittany
|
||||
2. mtl-style preferred
|
||||
3. no overly pointfree style
|
||||
157
README.md
157
README.md
@@ -1,37 +1,144 @@
|
||||
# ghcup
|
||||
`ghcup` makes it easy to install specific versions of `ghc` on GNU/Linux,
|
||||
macOS (aka Darwin) and FreeBSD and can also bootstrap a fresh Haskell developer environment from scratch.
|
||||
It follows the unix UNIX philosophy of [do one thing and do it well](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well).
|
||||
|
||||
A rewrite of ghcup in haskell.
|
||||
Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [pyenv](https://github.com/pyenv/pyenv) and [jenv](http://www.jenv.be).
|
||||
|
||||
## TODO
|
||||
*Ubuntu users may prefer [hvr's ppa](https://launchpad.net/~hvr/+archive/ubuntu/ghc).*
|
||||
|
||||
* create static ghcup binaries
|
||||
* adjust url in GHCupDownloads
|
||||
* add print-system-reqs command
|
||||
## Table of Contents
|
||||
|
||||
## Motivation
|
||||
* [Installation](#installation)
|
||||
* [Usage](#usage)
|
||||
* [Manpages](#manpages)
|
||||
* [Design goals](#design-goals)
|
||||
* [How](#how)
|
||||
* [Known users](#known-users)
|
||||
* [Known problems](#known-problems)
|
||||
* [FAQ](#faq)
|
||||
|
||||
Maintenance problems:
|
||||
## Installation
|
||||
|
||||
* 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
|
||||
### Simple bootstrap
|
||||
|
||||
Benefits of a rewrite:
|
||||
Follow the instructions at [https://www.haskell.org/ghcup/](https://www.haskell.org/ghcup/)
|
||||
|
||||
* 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)
|
||||
### Manual install
|
||||
|
||||
Downsides:
|
||||
Download the binary for your platform at [https://downloads.haskell.org/~ghcup/](https://downloads.haskell.org/~ghcup/)
|
||||
and place it into your `PATH` anywhere.
|
||||
|
||||
* building static binaries for all platforms (and possibly causing SSL/DNS problems)
|
||||
* still bootstrapping those binaries via a POSIX sh script
|
||||
Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) like so:
|
||||
|
||||
## Goals
|
||||
```sh
|
||||
export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
|
||||
```
|
||||
|
||||
## Usage
|
||||
|
||||
See `ghcup --help`.
|
||||
|
||||
Common use cases are:
|
||||
|
||||
```sh
|
||||
# list available ghc/cabal versions
|
||||
ghcup list
|
||||
|
||||
# install the recommended GHC version
|
||||
ghcup install
|
||||
|
||||
# install a specific GHC version
|
||||
ghcup install 8.2.2
|
||||
|
||||
# set the currently "active" GHC version
|
||||
ghcup set 8.4.4
|
||||
|
||||
# install cabal-install
|
||||
ghcup install-cabal
|
||||
|
||||
# update ghcup itself
|
||||
ghcup upgrade
|
||||
```
|
||||
|
||||
Generally this is meant to be used with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
|
||||
handles your haskell packages and can demand that [a specific version](https://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-flag---with-compiler) of `ghc` is available, which `ghcup` can do.
|
||||
|
||||
### Manpages
|
||||
|
||||
For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc.
|
||||
`MANPATH` may be required to be unset.
|
||||
|
||||
## Design goals
|
||||
|
||||
1. simplicity
|
||||
2. non-interactive
|
||||
3. portable (eh)
|
||||
4. do one thing and do it well (UNIX philosophy)
|
||||
|
||||
### Non-goals
|
||||
|
||||
1. invoking `sudo`, `apt-get` or *any* package manager
|
||||
2. handling system packages
|
||||
3. handling cabal projects
|
||||
4. being a stack alternative
|
||||
|
||||
## How
|
||||
|
||||
Installs a specified GHC version into `~/.ghcup/ghc/<ver>`, and places `ghc-<ver>` symlinks in `~/.ghcup/bin/`.
|
||||
|
||||
Optionally, an unversioned `ghc` link can point to a default version of your choice.
|
||||
|
||||
This uses precompiled GHC binaries that have been compiled on fedora/debian by [upstream GHC](https://www.haskell.org/ghc/download_ghc_8_6_1.html#binaries).
|
||||
|
||||
Alternatively, you can also tell it to compile from source (note that this might fail due to missing requirements).
|
||||
|
||||
In addition this script can also install `cabal-install`.
|
||||
|
||||
## Known users
|
||||
|
||||
* [vabal](https://github.com/Franciman/vabal)
|
||||
|
||||
## Known problems
|
||||
|
||||
### Limited distributions supported
|
||||
|
||||
Currently only GNU/Linux distributions compatible with the [upstream GHC](https://www.haskell.org/ghc/download_ghc_8_6_1.html#binaries) binaries are supported.
|
||||
|
||||
### Precompiled binaries
|
||||
|
||||
Since this uses precompiled binaries you may run into
|
||||
several problems.
|
||||
|
||||
#### Missing libtinfo (ncurses)
|
||||
|
||||
You may run into problems with *ncurses* and **missing libtinfo**, in case
|
||||
your distribution doesn't use the legacy way of building
|
||||
ncurses and has no compatibility symlinks in place.
|
||||
|
||||
Ask your distributor on how to solve this or
|
||||
try to compile from source via `ghcup compile <version>`.
|
||||
|
||||
#### Libnuma required
|
||||
|
||||
This was a [bug](https://ghc.haskell.org/trac/ghc/ticket/15688) in the build system of some GHC versions that lead to
|
||||
unconditionally enabled libnuma support. To mitigate this you might have to install the libnuma
|
||||
package of your distribution. See [here](https://gitlab.haskell.org/haskell/ghcup/issues/58) for a discussion.
|
||||
|
||||
### Compilation
|
||||
|
||||
Although this script can compile GHC for you, it's just a very thin
|
||||
wrapper around the build system. It makes no effort in trying
|
||||
to figure out whether you have the correct toolchain and
|
||||
the correct dependencies. Refer to [the official docs](https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation/Linux)
|
||||
on how to prepare your environment for building GHC.
|
||||
|
||||
## FAQ
|
||||
|
||||
1. Why reimplement stack?
|
||||
|
||||
ghcup is not a reimplementation of stack. The only common part is automatic installation of GHC, but even that differs in scope and design.
|
||||
|
||||
2. Why not support windows?
|
||||
|
||||
Consider using [Chocolatey](https://chocolatey.org/search?q=ghc) or [ghcups](https://github.com/kakkun61/ghcups).
|
||||
|
||||
* Correct low-level code
|
||||
* Good exception handling
|
||||
* Cleaner user interface
|
||||
|
||||
11
RELEASING.md
Normal file
11
RELEASING.md
Normal file
@@ -0,0 +1,11 @@
|
||||
# RELEASING
|
||||
|
||||
1. update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `_toolRequirements` type or the JSON representation of it. The version of the json represents the change increments. `ghcUpVer` is the current application version.
|
||||
|
||||
2. Add/fix downloads to `GHCupDownloads` module, then run `ghcup-gen gen` to generate the new json and validate it via `ghcup-gen check`.
|
||||
|
||||
3. Commit and git push with tag. Wait for tests to succeed.
|
||||
|
||||
4. Upload the new `ghcup-<ver>.json` to `webhost.haskell.org/ghcup/data/`.
|
||||
|
||||
5. Build ghcup releases for Linux (fully static), mac (with `-fcurl`) and FreeBSD (with `-fcurl`). Upload to `webhost.haskell.org/ghcup/bin/` and update symlinks.
|
||||
31
TODO.md
Normal file
31
TODO.md
Normal file
@@ -0,0 +1,31 @@
|
||||
# TODOs and Remarks
|
||||
|
||||
## Now
|
||||
|
||||
* ghcup migration
|
||||
* update static links
|
||||
|
||||
* releases, update download info and bootstrap-haskell
|
||||
|
||||
## Maybe
|
||||
|
||||
* maybe: changelog Show the changelog of a GHC release (online)
|
||||
* sign the JSON? (Or check gpg keys?)
|
||||
* testing (especially distro detection -> unit tests)
|
||||
|
||||
## Later
|
||||
|
||||
* i386 support
|
||||
* add support for RC/alpha/HEAD versions
|
||||
|
||||
## Cleanups
|
||||
|
||||
* too many decodeutf8
|
||||
* avoid alternative for IO
|
||||
* use plucky or oops instead of Excepts
|
||||
|
||||
## Questions
|
||||
|
||||
* mirror support
|
||||
* interactive handling when distro doesn't exist and we know the tarball is incompatible?
|
||||
* ghcup-with wrapper to execute a command with a given ghc in PATH?
|
||||
File diff suppressed because it is too large
Load Diff
11
app/ghcup-gen/GHCupInfo.hs
Normal file
11
app/ghcup-gen/GHCupInfo.hs
Normal file
@@ -0,0 +1,11 @@
|
||||
module GHCupInfo where
|
||||
|
||||
import GHCupDownloads
|
||||
import ToolRequirements
|
||||
import GHCup.Types
|
||||
|
||||
|
||||
ghcupInfo :: GHCupInfo
|
||||
ghcupInfo = GHCupInfo { _toolRequirements = toolRequirements
|
||||
, _ghcupDownloads = ghcupDownloads
|
||||
}
|
||||
@@ -1,20 +1,25 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
|
||||
module Main where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Logger
|
||||
import GHCupDownloads
|
||||
import GHCupInfo
|
||||
|
||||
import Data.Aeson ( eitherDecode )
|
||||
import Data.Aeson ( eitherDecode, encode )
|
||||
import Data.Aeson.Encode.Pretty
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Data.Semigroup ( (<>) )
|
||||
#endif
|
||||
import Options.Applicative hiding ( style )
|
||||
import System.Console.Pretty
|
||||
import System.Exit
|
||||
@@ -57,10 +62,13 @@ outputP = fileOutput <|> stdOutput
|
||||
|
||||
data GenJSONOpts = GenJSONOpts
|
||||
{ output :: Maybe Output
|
||||
, pretty :: Bool
|
||||
}
|
||||
|
||||
genJSONOpts :: Parser GenJSONOpts
|
||||
genJSONOpts = GenJSONOpts <$> optional outputP
|
||||
genJSONOpts = GenJSONOpts <$> optional outputP <*> switch
|
||||
(short 'p' <> long "pretty" <> help "Make JSON output pretty (human readable)"
|
||||
)
|
||||
|
||||
|
||||
data Input
|
||||
@@ -130,14 +138,16 @@ main = do
|
||||
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
||||
>>= \Options {..} -> case optCommand of
|
||||
GenJSON gopts -> do
|
||||
let
|
||||
bs = encodePretty' (defConfig { confIndent = Spaces 2 })
|
||||
ghcupDownloads
|
||||
let bs True =
|
||||
encodePretty' (defConfig { confIndent = Spaces 2 }) ghcupInfo
|
||||
bs False = encode ghcupInfo
|
||||
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
|
||||
GenJSONOpts { output = Nothing, pretty } ->
|
||||
L.hPutStr stdout (bs pretty)
|
||||
GenJSONOpts { output = Just StdOutput, pretty } ->
|
||||
L.hPutStr stdout (bs pretty)
|
||||
GenJSONOpts { output = Just (FileOutput file), pretty } ->
|
||||
L.writeFile file (bs pretty)
|
||||
ValidateJSON vopts -> case vopts of
|
||||
ValidateJSONOpts { input = Nothing } ->
|
||||
L.getContents >>= valAndExit validate
|
||||
@@ -156,9 +166,8 @@ main = do
|
||||
|
||||
where
|
||||
valAndExit f contents = do
|
||||
av <- case eitherDecode contents of
|
||||
(GHCupInfo _ 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
|
||||
|
||||
|
||||
94
app/ghcup-gen/ToolRequirements.hs
Normal file
94
app/ghcup-gen/ToolRequirements.hs
Normal file
@@ -0,0 +1,94 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module ToolRequirements where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
||||
|
||||
|
||||
-- | Currently 'GHC' is used for both GHC and cabal to simplify
|
||||
-- this, until we need actual separation.
|
||||
toolRequirements :: ToolRequirements
|
||||
toolRequirements = M.fromList
|
||||
[ ( GHC
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, M.fromList
|
||||
[ ( Linux UnknownLinux
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, Requirements
|
||||
[]
|
||||
[s|You need the following packages: curl g++ gcc gmp make ncurses realpath xz-utils. Consult your distro documentation on the exact names of those packages.|]
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( Linux Alpine
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, Requirements
|
||||
[ "curl"
|
||||
, "gcc"
|
||||
, "g++"
|
||||
, "gmp-dev"
|
||||
, "ncurses-dev"
|
||||
, "libffi-dev"
|
||||
, "make"
|
||||
, "xz"
|
||||
, "tar"
|
||||
, "perl"
|
||||
]
|
||||
""
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( Linux Ubuntu
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, Requirements
|
||||
[ "build-essential"
|
||||
, "curl"
|
||||
, "libgmp-dev"
|
||||
, "libffi-dev"
|
||||
, "libncurses-dev"
|
||||
, "libtinfo5"
|
||||
]
|
||||
""
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( Darwin
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, Requirements
|
||||
[]
|
||||
"On OS X, in the course of running ghcup you will be given a dialog box to install the command line tools. Accept and the requirements will be installed for you. You will then need to run the command again."
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( FreeBSD
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, Requirements
|
||||
[ "curl"
|
||||
, "gcc"
|
||||
, "gmp"
|
||||
, "gmake"
|
||||
, "ncurses"
|
||||
, "perl5"
|
||||
, "libffi"
|
||||
, "libiconv"
|
||||
]
|
||||
""
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
@@ -161,7 +161,7 @@ validateTarballs dls = do
|
||||
|
||||
where
|
||||
downloadAll dli = do
|
||||
let settings = Settings True GHCupURL False
|
||||
let settings = Settings True False
|
||||
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = (\_ -> pure ())
|
||||
|
||||
@@ -1,8 +1,10 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
|
||||
@@ -11,22 +13,30 @@ module Main where
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Errors
|
||||
import GHCup.Platform
|
||||
import GHCup.Requirements
|
||||
import GHCup.Types
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.Version
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Bifunctor
|
||||
import Data.Char
|
||||
import Data.Either
|
||||
import Data.Functor
|
||||
import Data.List ( intercalate )
|
||||
import Data.Semigroup ( (<>) )
|
||||
import Data.String.Interpolate
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import Data.Void
|
||||
import GHC.IO.Encoding
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import HPath
|
||||
import HPath.IO
|
||||
@@ -45,6 +55,7 @@ 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
|
||||
import qualified Text.Megaparsec as MP
|
||||
|
||||
|
||||
|
||||
@@ -62,7 +73,8 @@ data Options = Options
|
||||
}
|
||||
|
||||
data Command
|
||||
= Install InstallCommand
|
||||
= Install InstallOptions
|
||||
| InstallCabal InstallOptions
|
||||
| SetGHC SetGHCOptions
|
||||
| List ListOptions
|
||||
| Rm RmOptions
|
||||
@@ -70,16 +82,15 @@ data Command
|
||||
| Compile CompileCommand
|
||||
| Upgrade UpgradeOpts
|
||||
| NumericVersion
|
||||
| ToolRequirements
|
||||
|
||||
data ToolVersion = ToolVersion Version
|
||||
| ToolTag Tag
|
||||
|
||||
|
||||
data InstallCommand = InstallGHC InstallOptions
|
||||
| InstallCabal InstallOptions
|
||||
|
||||
data InstallOptions = InstallOptions
|
||||
{ instVer :: Maybe ToolVersion
|
||||
{ instVer :: Maybe ToolVersion
|
||||
, instPlatform :: Maybe PlatformRequest
|
||||
}
|
||||
|
||||
data SetGHCOptions = SetGHCOptions
|
||||
@@ -102,9 +113,10 @@ data CompileCommand = CompileGHC CompileOptions
|
||||
|
||||
data CompileOptions = CompileOptions
|
||||
{ targetVer :: Version
|
||||
, bootstrapVer :: Version
|
||||
, bootstrapGhc :: Either Version (Path Abs)
|
||||
, jobs :: Maybe Int
|
||||
, buildConfig :: Maybe (Path Abs)
|
||||
, patchDir :: Maybe (Path Abs)
|
||||
}
|
||||
|
||||
data UpgradeOpts = UpgradeInplace
|
||||
@@ -118,23 +130,26 @@ opts =
|
||||
Options
|
||||
<$> switch
|
||||
(short 'v' <> long "verbose" <> help
|
||||
"Whether to enable verbosity (default: False)"
|
||||
"Enable verbosity"
|
||||
)
|
||||
<*> switch
|
||||
(short 'c' <> long "cache" <> help
|
||||
"Whether to cache downloads (default: False)"
|
||||
"Cache downloads in ~/.ghcup/cache"
|
||||
)
|
||||
<*> (optional
|
||||
(option
|
||||
(eitherReader parseUri)
|
||||
(short 's' <> long "url-source" <> metavar "URL" <> help
|
||||
"Alternative ghcup download info url" <> internal
|
||||
( 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)"
|
||||
"Skip tarball checksum verification"
|
||||
)
|
||||
<*> com
|
||||
where
|
||||
@@ -147,11 +162,29 @@ com =
|
||||
subparser
|
||||
( command
|
||||
"install"
|
||||
( Install
|
||||
<$> (info (installP <**> helper)
|
||||
(progDesc "Install or update GHC/cabal")
|
||||
)
|
||||
((info ((Install <$> installOpts) <**> helper)
|
||||
(progDesc "Install or update GHC")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"set"
|
||||
( SetGHC
|
||||
<$> (info (setGHCOpts <**> helper)
|
||||
(progDesc "Set currently active GHC version")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"rm"
|
||||
( Rm
|
||||
<$> (info (rmOpts <**> helper) (progDesc "Remove a GHC version"))
|
||||
)
|
||||
|
||||
<> command
|
||||
"install-cabal"
|
||||
((info ((InstallCabal <$> installOpts) <**> helper)
|
||||
(progDesc "Install or update cabal")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"list"
|
||||
( List
|
||||
@@ -162,39 +195,17 @@ com =
|
||||
<> command
|
||||
"upgrade"
|
||||
( Upgrade
|
||||
<$> (info
|
||||
(upgradeOptsP <**> helper)
|
||||
(progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
|
||||
<$> (info (upgradeOptsP <**> helper) (progDesc "Upgrade ghcup"))
|
||||
)
|
||||
<> command
|
||||
"compile"
|
||||
( Compile
|
||||
<$> (info (compileP <**> helper)
|
||||
(progDesc "Compile a tool from source")
|
||||
)
|
||||
)
|
||||
<> 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"
|
||||
@@ -204,32 +215,37 @@ com =
|
||||
( (\_ -> NumericVersion)
|
||||
<$> (info (helper) (progDesc "Show the numeric version"))
|
||||
)
|
||||
<> command
|
||||
"tool-requirements"
|
||||
( (\_ -> ToolRequirements)
|
||||
<$> (info (helper)
|
||||
(progDesc "Show the requirements for ghc/cabal")
|
||||
)
|
||||
)
|
||||
<> 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
|
||||
installOpts =
|
||||
(flip InstallOptions)
|
||||
<$> (optional
|
||||
(option
|
||||
(eitherReader platformParser)
|
||||
( short 'p'
|
||||
<> long "platform"
|
||||
<> metavar "PLATFORM"
|
||||
<> help
|
||||
"Override for platform (triple matching ghc tarball names), e.g. x86_64-fedora27-linux"
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> optional toolVersionArgument
|
||||
|
||||
|
||||
setGHCOpts :: Parser SetGHCOptions
|
||||
setGHCOpts = SetGHCOptions <$> optional toolVersionParser
|
||||
setGHCOpts = SetGHCOptions <$> optional toolVersionArgument
|
||||
|
||||
listOpts :: Parser ListOptions
|
||||
listOpts =
|
||||
@@ -253,7 +269,7 @@ listOpts =
|
||||
)
|
||||
|
||||
rmOpts :: Parser RmOptions
|
||||
rmOpts = RmOptions <$> versionParser
|
||||
rmOpts = RmOptions <$> versionArgument
|
||||
|
||||
|
||||
compileP :: Parser CompileCommand
|
||||
@@ -287,12 +303,16 @@ compileOpts =
|
||||
)
|
||||
<*> (option
|
||||
(eitherReader
|
||||
(bimap (const "Not a valid version") id . version . T.pack)
|
||||
(\x ->
|
||||
(bimap (const "Not a valid version") Left . version . T.pack $ x)
|
||||
<|> (bimap show Right . parseAbs . E.encodeUtf8 . T.pack $ x)
|
||||
)
|
||||
)
|
||||
( short 'b'
|
||||
<> long "bootstrap-version"
|
||||
<> metavar "BOOTSTRAP_VERSION"
|
||||
<> help "The GHC version to bootstrap with (must be installed)"
|
||||
<> long "bootstrap-ghc"
|
||||
<> metavar "BOOTSTRAP_GHC"
|
||||
<> help
|
||||
"The GHC version (or full path) to bootstrap with (must be installed)"
|
||||
)
|
||||
)
|
||||
<*> optional
|
||||
@@ -315,13 +335,19 @@ compileOpts =
|
||||
"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"
|
||||
)
|
||||
<*> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(\x ->
|
||||
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
|
||||
String
|
||||
(Path Abs)
|
||||
)
|
||||
)
|
||||
(short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
|
||||
"Absolute path to patch directory (applied in order, uses -p1)"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
toolVersionParser :: Parser ToolVersion
|
||||
@@ -331,16 +357,44 @@ toolVersionParser = verP <|> toolP
|
||||
toolP =
|
||||
ToolTag
|
||||
<$> (option
|
||||
(eitherReader
|
||||
(\s' -> case fmap toLower s' of
|
||||
"recommended" -> Right Recommended
|
||||
"latest" -> Right Latest
|
||||
other -> Left ([i|Unknown tag #{other}|])
|
||||
)
|
||||
)
|
||||
(eitherReader tagEither)
|
||||
(short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
|
||||
)
|
||||
|
||||
-- | same as toolVersionParser, except as an argument.
|
||||
toolVersionArgument :: Parser ToolVersion
|
||||
toolVersionArgument =
|
||||
argument (eitherReader toolVersionEither) (metavar "VERSION|TAG")
|
||||
|
||||
|
||||
versionArgument :: Parser Version
|
||||
versionArgument = argument
|
||||
(eitherReader versionEither)
|
||||
(metavar "VERSION")
|
||||
|
||||
versionParser :: Parser Version
|
||||
versionParser = option
|
||||
(eitherReader versionEither)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
|
||||
)
|
||||
|
||||
tagEither :: String -> Either String Tag
|
||||
tagEither s' = case fmap toLower s' of
|
||||
"recommended" -> Right Recommended
|
||||
"latest" -> Right Latest
|
||||
other -> Left ([i|Unknown tag #{other}|])
|
||||
|
||||
versionEither :: String -> Either String Version
|
||||
versionEither s' =
|
||||
-- 'version' is a bit too lax and will parse typoed tags
|
||||
case readMaybe ((:[]) . head $ s') :: Maybe Int of
|
||||
Just _ -> bimap (const "Not a valid version") id . version . T.pack $ s'
|
||||
Nothing -> Left "Not a valid version"
|
||||
|
||||
toolVersionEither :: String -> Either String ToolVersion
|
||||
toolVersionEither s' =
|
||||
bimap id ToolTag (tagEither s') <|> bimap id ToolVersion (versionEither s')
|
||||
|
||||
|
||||
toolParser :: String -> Either String Tool
|
||||
toolParser s' | t == T.pack "ghc" = Right GHC
|
||||
@@ -356,11 +410,83 @@ criteriaParser s' | t == T.pack "installed" = Right ListInstalled
|
||||
where t = T.toLower (T.pack s')
|
||||
|
||||
|
||||
platformParser :: String -> Either String PlatformRequest
|
||||
platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
|
||||
Right r -> pure r
|
||||
Left e -> Left $ errorBundlePretty e
|
||||
where
|
||||
archP :: MP.Parsec Void Text Architecture
|
||||
archP = (MP.try (MP.chunk "x86_64" $> A_64)) <|> (MP.chunk "i386" $> A_32)
|
||||
platformP :: MP.Parsec Void Text PlatformRequest
|
||||
platformP = choice'
|
||||
[ (\a mv -> PlatformRequest a FreeBSD mv)
|
||||
<$> (archP <* MP.chunk "-")
|
||||
<*> ( MP.chunk "portbld"
|
||||
*> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
|
||||
<|> pure Nothing
|
||||
)
|
||||
<* MP.chunk "-freebsd"
|
||||
)
|
||||
, (\a mv -> PlatformRequest a Darwin mv)
|
||||
<$> (archP <* MP.chunk "-")
|
||||
<*> ( MP.chunk "apple"
|
||||
*> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof))
|
||||
<|> pure Nothing
|
||||
)
|
||||
<* MP.chunk "-darwin"
|
||||
)
|
||||
, (\a d mv -> PlatformRequest a (Linux d) mv)
|
||||
<$> (archP <* MP.chunk "-")
|
||||
<*> distroP
|
||||
<*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing
|
||||
)
|
||||
<* MP.chunk "-linux"
|
||||
)
|
||||
]
|
||||
distroP :: MP.Parsec Void Text LinuxDistro
|
||||
distroP = choice'
|
||||
[ MP.chunk "debian" $> Debian
|
||||
, MP.chunk "deb" $> Debian
|
||||
, MP.chunk "ubuntu" $> Ubuntu
|
||||
, MP.chunk "mint" $> Mint
|
||||
, MP.chunk "fedora" $> Fedora
|
||||
, MP.chunk "centos" $> CentOS
|
||||
, MP.chunk "redhat" $> RedHat
|
||||
, MP.chunk "alpine" $> Alpine
|
||||
, MP.chunk "gentoo" $> Gentoo
|
||||
, MP.chunk "exherbo" $> Exherbo
|
||||
, MP.chunk "unknown" $> UnknownLinux
|
||||
]
|
||||
verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
|
||||
verP suffix = do
|
||||
ver <- parseUntil suffix
|
||||
if T.null ver
|
||||
then fail "empty version"
|
||||
else do
|
||||
rest <- MP.getInput
|
||||
MP.setInput ver
|
||||
v <- versioning'
|
||||
MP.setInput rest
|
||||
pure v
|
||||
|
||||
choice' [] = fail "Empty list"
|
||||
choice' [x ] = x
|
||||
choice' (x : xs) = MP.try x <|> choice' xs
|
||||
|
||||
parseUntil :: MP.Parsec Void Text Text -> MP.Parsec Void Text Text
|
||||
parseUntil p = do
|
||||
(MP.try (MP.lookAhead p) $> mempty)
|
||||
<|> (do
|
||||
c <- T.singleton <$> MP.anySingle
|
||||
c2 <- parseUntil p
|
||||
pure (c `mappend` c2)
|
||||
)
|
||||
|
||||
|
||||
toSettings :: Options -> Settings
|
||||
toSettings Options {..} =
|
||||
let cache = optCache
|
||||
urlSource = maybe GHCupURL OwnSource optUrlSource
|
||||
noVerify = optNoVerify
|
||||
let cache = optCache
|
||||
noVerify = optNoVerify
|
||||
in Settings { .. }
|
||||
|
||||
|
||||
@@ -397,8 +523,12 @@ main = do
|
||||
>>= \opt@Options {..} -> do
|
||||
let settings = toSettings opt
|
||||
|
||||
-- create ~/.ghcup dir
|
||||
ghcdir <- ghcupBaseDir
|
||||
createDirIfMissing newDirPerms ghcdir
|
||||
|
||||
-- logger interpreter
|
||||
logfile <- initGHCupFileLogging ([rel|ghcup.log|] :: Path Rel)
|
||||
logfile <- initGHCupFileLogging [rel|ghcup.log|]
|
||||
let runLogger = myLoggerT LoggerConfig
|
||||
{ lcPrintDebug = optVerbose
|
||||
, colorOutter = B.hPut stderr
|
||||
@@ -416,7 +546,6 @@ main = do
|
||||
, DistroNotFound
|
||||
, FileDoesNotExistError
|
||||
, CopyError
|
||||
, JSONError
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
@@ -427,22 +556,21 @@ main = do
|
||||
, DownloadFailed
|
||||
]
|
||||
|
||||
let runSetGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
, TagNotFound
|
||||
, JSONError
|
||||
, TagNotFound
|
||||
, DownloadFailed
|
||||
]
|
||||
let
|
||||
runSetGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
, TagNotFound
|
||||
, TagNotFound
|
||||
]
|
||||
|
||||
let runListGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[FileDoesNotExistError , JSONError , DownloadFailed]
|
||||
. runE @'[FileDoesNotExistError]
|
||||
|
||||
let runRmGHC =
|
||||
runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
||||
@@ -461,12 +589,15 @@ main = do
|
||||
@'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, GHCupSetError
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
, NotFoundInPATH
|
||||
, PatchFailed
|
||||
, UnknownArchive
|
||||
--
|
||||
, JSONError
|
||||
]
|
||||
|
||||
let runCompileCabal =
|
||||
@@ -474,12 +605,15 @@ main = do
|
||||
. flip runReaderT settings
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ JSONError
|
||||
, UnknownArchive
|
||||
, NoDownload
|
||||
@'[ BuildFailed
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, BuildFailed
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
, PatchFailed
|
||||
, UnknownArchive
|
||||
]
|
||||
|
||||
let runUpgrade =
|
||||
@@ -493,30 +627,42 @@ main = do
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, FileDoesNotExistError
|
||||
, JSONError
|
||||
, DownloadFailed
|
||||
, CopyError
|
||||
, DownloadFailed
|
||||
]
|
||||
|
||||
(GHCupInfo treq dls) <-
|
||||
( runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[JSONError , DownloadFailed]
|
||||
$ liftE
|
||||
$ getDownloads (maybe GHCupURL OwnSource optUrlSource)
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> pure r
|
||||
VLeft e ->
|
||||
runLogger
|
||||
($(logError) [i|Error fetching download info: #{e}|])
|
||||
>> exitFailure
|
||||
runLogger $ checkForUpdates dls
|
||||
|
||||
case optCommand of
|
||||
Install (InstallGHC InstallOptions {..}) ->
|
||||
Install (InstallOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
dls <- liftE getDownloads
|
||||
v <- liftE $ fromVersion dls instVer GHC
|
||||
liftE $ installGHCBin dls v Nothing
|
||||
v <- liftE $ fromVersion dls instVer GHC
|
||||
liftE $ installGHCBin dls v instPlatform
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
$ $(logInfo) ([s|GHC installation successful|])
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo) ("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.|]
|
||||
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.|]
|
||||
)
|
||||
>> exitFailure
|
||||
VLeft e -> do
|
||||
@@ -524,16 +670,15 @@ Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.
|
||||
$(logError) [i|#{e}|]
|
||||
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
|
||||
exitFailure
|
||||
Install (InstallCabal InstallOptions {..}) ->
|
||||
InstallCabal (InstallOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
dls <- liftE getDownloads
|
||||
v <- liftE $ fromVersion dls instVer Cabal
|
||||
liftE $ installCabalBin dls v Nothing
|
||||
v <- liftE $ fromVersion dls instVer Cabal
|
||||
liftE $ installCabalBin dls v instPlatform
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
$ $(logInfo) ([s|Cabal installation successful|])
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo) ("Cabal installation successful")
|
||||
VLeft (V (AlreadyInstalled _ v)) ->
|
||||
runLogger $ $(logWarn)
|
||||
[i|Cabal ver #{prettyVer v} already installed|]
|
||||
@@ -546,20 +691,18 @@ Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.
|
||||
SetGHC (SetGHCOptions {..}) ->
|
||||
void
|
||||
$ (runSetGHC $ do
|
||||
dls <- liftE getDownloads
|
||||
v <- liftE $ fromVersion dls ghcVer GHC
|
||||
v <- liftE $ fromVersion dls ghcVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo) ([s|GHC successfully set|])
|
||||
runLogger $ $(logInfo) ("GHC successfully set")
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
List (ListOptions {..}) ->
|
||||
void
|
||||
$ (runListGHC $ do
|
||||
dls <- liftE getDownloads
|
||||
liftIO $ listVersions dls lTool lCriteria
|
||||
)
|
||||
>>= \case
|
||||
@@ -590,21 +733,20 @@ Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.
|
||||
Compile (CompileGHC CompileOptions {..}) ->
|
||||
void
|
||||
$ (runCompileGHC $ do
|
||||
dls <- liftE getDownloads
|
||||
liftE
|
||||
$ compileGHC dls targetVer bootstrapVer jobs buildConfig
|
||||
$ compileGHC dls targetVer bootstrapGhc jobs buildConfig patchDir
|
||||
)
|
||||
>>= \case
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo)
|
||||
([s|GHC successfully compiled and installed|])
|
||||
("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.|]
|
||||
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.|]
|
||||
)
|
||||
>> exitFailure
|
||||
VLeft e ->
|
||||
@@ -613,20 +755,16 @@ Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.
|
||||
Compile (CompileCabal CompileOptions {..}) ->
|
||||
void
|
||||
$ (runCompileCabal $ do
|
||||
dls <- liftE getDownloads
|
||||
liftE $ compileCabal dls
|
||||
targetVer
|
||||
bootstrapVer
|
||||
jobs
|
||||
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir
|
||||
)
|
||||
>>= \case
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo)
|
||||
([s|Cabal successfully compiled and installed|])
|
||||
("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.|]
|
||||
Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.|]
|
||||
)
|
||||
>> exitFailure
|
||||
VLeft e ->
|
||||
@@ -641,11 +779,10 @@ Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.
|
||||
(UpgradeAt p) -> pure $ Just p
|
||||
UpgradeGHCupDir -> do
|
||||
bdir <- liftIO $ ghcupBinDir
|
||||
pure (Just (bdir </> ([rel|ghcup|] :: Path Rel)))
|
||||
pure (Just (bdir </> [rel|ghcup|]))
|
||||
|
||||
void
|
||||
$ (runUpgrade $ do
|
||||
dls <- liftE getDownloads
|
||||
liftE $ upgradeGHCup dls target
|
||||
)
|
||||
>>= \case
|
||||
@@ -658,6 +795,21 @@ Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
NumericVersion -> T.hPutStr stdout (prettyPVP ghcUpVer)
|
||||
ToolRequirements -> (runLogger $ runE
|
||||
@'[ NoCompatiblePlatform
|
||||
, DistroNotFound
|
||||
, NoToolRequirements
|
||||
] $ do
|
||||
platform <- liftE $ getPlatform
|
||||
req <- (getCommonRequirements platform $ treq)
|
||||
?? NoToolRequirements
|
||||
liftIO $ T.hPutStr stdout (prettyRequirements req))
|
||||
>>= \case
|
||||
VRight r -> pure r
|
||||
VLeft e ->
|
||||
runLogger
|
||||
($(logError) [i|Error getting tool requirements: #{e}|])
|
||||
>> exitFailure
|
||||
pure ()
|
||||
|
||||
|
||||
@@ -677,6 +829,9 @@ fromVersion av (Just (ToolTag Recommended)) tool =
|
||||
|
||||
printListResult :: [ListResult] -> IO ()
|
||||
printListResult lr = do
|
||||
-- https://gitlab.haskell.org/ghc/ghc/issues/8118
|
||||
setLocaleEncoding utf8
|
||||
|
||||
let
|
||||
formatted =
|
||||
gridString
|
||||
@@ -700,3 +855,12 @@ printListResult lr = do
|
||||
)
|
||||
lr
|
||||
putStrLn $ formatted
|
||||
|
||||
|
||||
checkForUpdates :: (MonadFail m, MonadLogger m) => GHCupDownloads -> m ()
|
||||
checkForUpdates dls = do
|
||||
forM_ (getLatest dls GHCup) $ \l -> do
|
||||
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
|
||||
when (l > ghc_ver)
|
||||
$ $(logWarn)
|
||||
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
|
||||
|
||||
201
bootstrap-haskell
Executable file
201
bootstrap-haskell
Executable file
@@ -0,0 +1,201 @@
|
||||
#!/bin/sh
|
||||
|
||||
# safety subshell to avoid executing anything in case this script is not downloaded properly
|
||||
(
|
||||
|
||||
: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
|
||||
|
||||
die() {
|
||||
(>&2 printf "\\033[0;31m%s\\033[0m\\n" "$1")
|
||||
exit 2
|
||||
}
|
||||
|
||||
edo()
|
||||
{
|
||||
"$@" || die "\"$*\" failed!"
|
||||
}
|
||||
|
||||
eghcup() {
|
||||
if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
|
||||
edo ghcup "$@"
|
||||
else
|
||||
edo ghcup --verbose "$@"
|
||||
fi
|
||||
}
|
||||
|
||||
download_ghcup() {
|
||||
_plat="$(uname -s)"
|
||||
_arch=$(uname -m)
|
||||
|
||||
case "${_plat}" in
|
||||
"linux"|"Linux")
|
||||
case "${_arch}" in
|
||||
x86_64|amd64)
|
||||
_url=https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup
|
||||
;;
|
||||
i*86)
|
||||
_url=https://downloads.haskell.org/~ghcup/i386-linux-ghcup
|
||||
;;
|
||||
*) die "Unknown architecture: ${_arch}"
|
||||
;;
|
||||
esac
|
||||
;;
|
||||
"FreeBSD"|"freebsd")
|
||||
case "${_arch}" in
|
||||
x86_64|amd64)
|
||||
;;
|
||||
i*86)
|
||||
die "i386 currently not supported!"
|
||||
;;
|
||||
*) die "Unknown architecture: ${_arch}"
|
||||
;;
|
||||
esac
|
||||
_url=https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup
|
||||
;;
|
||||
"Darwin"|"darwin")
|
||||
case "${_arch}" in
|
||||
x86_64|amd64)
|
||||
;;
|
||||
i*86)
|
||||
die "i386 currently not supported!"
|
||||
;;
|
||||
*) die "Unknown architecture: ${_arch}"
|
||||
;;
|
||||
esac
|
||||
_url=https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup ;;
|
||||
*) die "Unknown platform: ${_plat}"
|
||||
;;
|
||||
esac
|
||||
|
||||
edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
|
||||
|
||||
unset _plat _arch _url
|
||||
}
|
||||
|
||||
|
||||
echo
|
||||
echo "Welcome to Haskell!"
|
||||
echo
|
||||
echo "This will download and install the Glasgow Haskell Compiler (GHC)"
|
||||
echo "and the Cabal build tool."
|
||||
echo
|
||||
echo "ghcup installs only into the following directory, which can be removed anytime:"
|
||||
echo " $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
|
||||
echo
|
||||
|
||||
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "Press ENTER to proceed"
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "or ctrl-c to abort."
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "Note that this script can be re-run at any given time."
|
||||
echo
|
||||
# Wait for user input to continue.
|
||||
# shellcheck disable=SC2034
|
||||
read -r answer </dev/tty
|
||||
fi
|
||||
|
||||
edo mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
|
||||
|
||||
if command -V "ghcup" >/dev/null 2>&1 ; then
|
||||
if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
|
||||
eghcup upgrade
|
||||
fi
|
||||
else
|
||||
download_ghcup
|
||||
edo chmod +x "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
|
||||
|
||||
cat <<-EOF > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env || die "Failed to create env file"
|
||||
export PATH="\$HOME/.cabal/bin:\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/bin:\$PATH"
|
||||
EOF
|
||||
# shellcheck disable=SC1090
|
||||
edo . "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env
|
||||
fi
|
||||
|
||||
echo
|
||||
echo "$(ghcup tool-requirements)"
|
||||
echo
|
||||
|
||||
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "Press ENTER to proceed"
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "or ctrl-c to abort."
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "Installation may take a while."
|
||||
echo
|
||||
|
||||
# Wait for user input to continue.
|
||||
# shellcheck disable=SC2034
|
||||
read -r answer </dev/tty
|
||||
fi
|
||||
|
||||
eghcup --cache install
|
||||
|
||||
eghcup set
|
||||
eghcup --cache install-cabal
|
||||
|
||||
edo cabal new-update
|
||||
|
||||
printf "\\033[0;35m%s\\033[0m\\n" ""
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "Installation done!"
|
||||
printf "\\033[0;35m%s\\033[0m\\n" ""
|
||||
|
||||
if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
|
||||
echo "In order to run ghc and cabal, you need to adjust your PATH variable."
|
||||
echo "You may want to source '$GHCUP_INSTALL_BASE_PREFIX/.ghcup/env' in your shell"
|
||||
echo "configuration to do so (e.g. ~/.bashrc)."
|
||||
|
||||
case $SHELL in
|
||||
*/zsh) # login shell is zsh
|
||||
GHCUP_PROFILE_FILE="$HOME/.zshrc"
|
||||
MY_SHELL="zsh" ;;
|
||||
*/bash) # login shell is bash
|
||||
if [ -f "$HOME/.bashrc" ] ; then # bashrc is not sourced by default, so assume it isn't if file does not exist
|
||||
GHCUP_PROFILE_FILE="$HOME/.bashrc"
|
||||
else
|
||||
GHCUP_PROFILE_FILE="$HOME/.bash_profile"
|
||||
fi
|
||||
|
||||
MY_SHELL="bash" ;;
|
||||
*/sh) # login shell is sh, but might be a symlink to bash or zsh
|
||||
if [ -n "${BASH}" ] ; then
|
||||
if [ -f "$HOME/.bashrc" ] ; then # bashrc is not sourced by default, so assume it isn't if file does not exist
|
||||
GHCUP_PROFILE_FILE="$HOME/.bashrc"
|
||||
else
|
||||
GHCUP_PROFILE_FILE="$HOME/.bash_profile"
|
||||
fi
|
||||
|
||||
MY_SHELL="bash"
|
||||
elif [ -n "${ZSH_VERSION}" ] ; then
|
||||
GHCUP_PROFILE_FILE="$HOME/.zshrc"
|
||||
MY_SHELL="zsh"
|
||||
else
|
||||
exit 0
|
||||
fi
|
||||
;;
|
||||
*) exit 0 ;;
|
||||
esac
|
||||
|
||||
|
||||
printf "\\033[0;35m%s\\033[0m\\n" ""
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "Detected ${MY_SHELL} shell on your system..."
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "If you want ghcup to automatically add the required PATH variable to \"${GHCUP_PROFILE_FILE}\""
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "answer with YES, otherwise with NO and press ENTER."
|
||||
printf "\\033[0;35m%s\\033[0m\\n" ""
|
||||
|
||||
while true; do
|
||||
read -r next_answer </dev/tty
|
||||
|
||||
case $next_answer in
|
||||
[Yy]*)
|
||||
echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
|
||||
printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session."
|
||||
exit 0;;
|
||||
[Nn]*)
|
||||
exit 0;;
|
||||
*)
|
||||
echo "Please type YES or NO and press enter.";;
|
||||
esac
|
||||
done
|
||||
fi
|
||||
)
|
||||
|
||||
# vim: tabstop=4 shiftwidth=4 expandtab
|
||||
|
||||
@@ -1,7 +1,5 @@
|
||||
packages: ./ghcup.cabal
|
||||
|
||||
with-compiler: ghc-8.6.5
|
||||
|
||||
optimization: 2
|
||||
|
||||
package streamly
|
||||
@@ -13,3 +11,6 @@ package ghcup
|
||||
package tar-bytestring
|
||||
ghc-options: -O2
|
||||
|
||||
constraints: http-io-streams -brotli
|
||||
|
||||
allow-newer: base
|
||||
|
||||
@@ -1,229 +0,0 @@
|
||||
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
|
||||
14
docker/build.sh
Normal file
14
docker/build.sh
Normal file
@@ -0,0 +1,14 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -ex
|
||||
|
||||
cd /app
|
||||
|
||||
cabal v2-update
|
||||
|
||||
cabal v2-install \
|
||||
--install-method=copy \
|
||||
--overwrite-policy=always \
|
||||
--installdir="/bin" \
|
||||
--ghc-options='-optl-static'
|
||||
|
||||
1
ghcup-0.0.1.json
Normal file
1
ghcup-0.0.1.json
Normal file
File diff suppressed because one or more lines are too long
582
ghcup.cabal
582
ghcup.cabal
@@ -1,234 +1,388 @@
|
||||
cabal-version: 2.2
|
||||
cabal-version: 3.0
|
||||
name: ghcup
|
||||
version: 0.1.1
|
||||
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.
|
||||
|
||||
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
|
||||
homepage: https://gitlab.haskell.org/haskell/ghcup-hs
|
||||
bug-reports: https://gitlab.haskell.org/haskell/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
|
||||
type: git
|
||||
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
|
||||
|
||||
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 }
|
||||
flag Curl
|
||||
description: Use curl instead of http-io-streams for download
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
common HsOpenSSL
|
||||
build-depends: HsOpenSSL >=0.11.4.18
|
||||
|
||||
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 base16-bytestring
|
||||
build-depends: base16-bytestring >= 0.1.1.6
|
||||
|
||||
common binary
|
||||
build-depends: binary >=0.8.6.0
|
||||
|
||||
common bytestring
|
||||
build-depends: bytestring >=0.10
|
||||
|
||||
common bz2
|
||||
build-depends: bz2 >=0.5.0.5
|
||||
|
||||
common case-insensitive
|
||||
build-depends: case-insensitive >=1.2.1.0
|
||||
|
||||
common concurrent-output
|
||||
build-depends: concurrent-output >=1.10.11
|
||||
|
||||
common containers
|
||||
build-depends: containers >=0.6
|
||||
|
||||
common cryptohash-sha256
|
||||
build-depends: cryptohash-sha256 >= 0.11.101.0
|
||||
|
||||
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 hpath
|
||||
build-depends: hpath >=0.11
|
||||
|
||||
common hpath-directory
|
||||
build-depends: hpath-directory >=0.13.3
|
||||
|
||||
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.13.2
|
||||
|
||||
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 megaparsec
|
||||
build-depends: megaparsec >=8.0.0
|
||||
|
||||
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 regex-posix
|
||||
build-depends: regex-posix >=0.96
|
||||
|
||||
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.1
|
||||
|
||||
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 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
|
||||
default-language: Haskell2010
|
||||
ghc-options:
|
||||
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
|
||||
-fwarn-incomplete-record-updates -threaded
|
||||
|
||||
default-extensions:
|
||||
LambdaCase
|
||||
MultiWayIf
|
||||
PackageImports
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
Strict
|
||||
StrictData
|
||||
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
|
||||
import:
|
||||
config
|
||||
, base
|
||||
, base16-bytestring
|
||||
, aeson
|
||||
, ascii-string
|
||||
, async
|
||||
, attoparsec
|
||||
, binary
|
||||
, bytestring
|
||||
, bz2
|
||||
, case-insensitive
|
||||
, concurrent-output
|
||||
, containers
|
||||
, cryptohash-sha256
|
||||
, generics-sop
|
||||
, haskus-utils-types
|
||||
, haskus-utils-variant
|
||||
, hpath
|
||||
, hpath-directory
|
||||
, hpath-filepath
|
||||
, hpath-io
|
||||
, hpath-posix
|
||||
, language-bash
|
||||
, lzma
|
||||
, monad-logger
|
||||
, mtl
|
||||
, optics
|
||||
, optics-vl
|
||||
, parsec
|
||||
, pretty-terminal
|
||||
, regex-posix
|
||||
, resourcet
|
||||
, safe
|
||||
, safe-exceptions
|
||||
, streamly
|
||||
, streamly-posix
|
||||
, streamly-bytestring
|
||||
, strict-base
|
||||
, string-interpolate
|
||||
, tar-bytestring
|
||||
, template-haskell
|
||||
, text
|
||||
, time
|
||||
, transformers
|
||||
, unix
|
||||
, unix-bytestring
|
||||
, uri-bytestring
|
||||
, utf8-string
|
||||
, vector
|
||||
, versions
|
||||
, word8
|
||||
, zlib
|
||||
|
||||
exposed-modules:
|
||||
GHCup
|
||||
GHCup.Download
|
||||
GHCup.Download.Utils
|
||||
GHCup.Errors
|
||||
GHCup.Platform
|
||||
GHCup.Requirements
|
||||
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
|
||||
hs-source-dirs: lib
|
||||
|
||||
if !flag(curl)
|
||||
import:
|
||||
, HsOpenSSL
|
||||
, http-io-streams
|
||||
, io-streams
|
||||
, terminal-progress-bar
|
||||
exposed-modules: GHCup.Download.IOStreams
|
||||
else
|
||||
cpp-options: -DCURL
|
||||
|
||||
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
|
||||
import:
|
||||
config
|
||||
, base
|
||||
, bytestring
|
||||
, containers
|
||||
, haskus-utils-variant
|
||||
, hpath
|
||||
, hpath-io
|
||||
, megaparsec
|
||||
, monad-logger
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, pretty-terminal
|
||||
, resourcet
|
||||
, string-interpolate
|
||||
, table-layout
|
||||
, text
|
||||
, uri-bytestring
|
||||
, utf8-string
|
||||
, versions
|
||||
|
||||
--
|
||||
main-is: Main.hs
|
||||
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: ghcup
|
||||
hs-source-dirs: app/ghcup
|
||||
default-language: Haskell2010
|
||||
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
|
||||
import:
|
||||
config
|
||||
, base
|
||||
, aeson
|
||||
, aeson-pretty
|
||||
, bytestring
|
||||
, containers
|
||||
, haskus-utils-variant
|
||||
, hpath
|
||||
, monad-logger
|
||||
, mtl
|
||||
, optics
|
||||
, optparse-applicative
|
||||
, pretty-terminal
|
||||
, resourcet
|
||||
, safe-exceptions
|
||||
, string-interpolate
|
||||
, table-layout
|
||||
, text
|
||||
, transformers
|
||||
, uri-bytestring
|
||||
, utf8-string
|
||||
, versions
|
||||
|
||||
--
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
GHCupDownloads
|
||||
GHCupInfo
|
||||
ToolRequirements
|
||||
Validate
|
||||
|
||||
-- other-extensions:
|
||||
build-depends: ghcup
|
||||
hs-source-dirs: app/ghcup-gen
|
||||
default-language: Haskell2010
|
||||
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
|
||||
default-language: Haskell2010
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: MyLibTest.hs
|
||||
build-depends: base >=4.12.0.0
|
||||
|
||||
269
lib/GHCup.hs
269
lib/GHCup.hs
@@ -1,12 +1,14 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module GHCup where
|
||||
|
||||
@@ -27,10 +29,11 @@ import GHCup.Version
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
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 )
|
||||
@@ -50,8 +53,7 @@ import Prelude hiding ( abs
|
||||
)
|
||||
import System.IO.Error
|
||||
import System.Posix.FilePath ( getSearchPath )
|
||||
import System.Posix.RawFilePath.Directory.Errors
|
||||
( hideError )
|
||||
import System.Posix.Files.ByteString
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Map.Strict as Map
|
||||
@@ -95,27 +97,33 @@ installGHCBin bDls ver mpfReq = do
|
||||
whenM (liftIO $ toolAlreadyInstalled GHC ver)
|
||||
$ (throwE $ AlreadyInstalled GHC ver)
|
||||
Settings {..} <- lift ask
|
||||
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
|
||||
|
||||
-- download (or use cached version)
|
||||
dlinfo <- liftE $ getDownloadInfo bDls GHC ver mpfReq
|
||||
dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
||||
|
||||
-- prepare paths
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
|
||||
catchAllE
|
||||
(\es ->
|
||||
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
|
||||
>> throwE (BuildFailed archiveSubdir es)
|
||||
)
|
||||
$ installGHC' archiveSubdir ghcdir
|
||||
-- Be careful about cleanup. We must catch both pure exceptions
|
||||
-- as well as async ones.
|
||||
flip onException
|
||||
(liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
|
||||
$ catchAllE
|
||||
(\es -> do
|
||||
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
|
||||
>> throwE (BuildFailed workdir es)
|
||||
)
|
||||
$ installGHC' workdir ghcdir
|
||||
|
||||
-- only clean up dir if the build succeeded
|
||||
liftIO $ deleteDirRecursive tmpUnpack
|
||||
@@ -129,19 +137,14 @@ installGHCBin bDls ver mpfReq = do
|
||||
-> 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|]
|
||||
lift $ $(logInfo) "Installing GHC (this may take a while)"
|
||||
lEM $ liftIO $ execLogged "./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)
|
||||
["--prefix=" <> toFilePath inst]
|
||||
[rel|ghc-configure|]
|
||||
(Just path)
|
||||
Nothing
|
||||
lEM $ liftIO $ make ["install"] (Just path)
|
||||
pure ()
|
||||
|
||||
|
||||
@@ -170,22 +173,24 @@ installCabalBin :: ( MonadMask m
|
||||
installCabalBin bDls ver mpfReq = do
|
||||
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
|
||||
Settings {..} <- lift ask
|
||||
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
|
||||
|
||||
-- download (or use cached version)
|
||||
dlinfo <- liftE $ getDownloadInfo bDls Cabal ver mpfReq
|
||||
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls
|
||||
dl <- liftE $ downloadCached dlinfo Nothing
|
||||
|
||||
-- unpack
|
||||
tmpUnpack <- lift withGHCupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
||||
|
||||
-- prepare paths
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
|
||||
|
||||
liftE $ installCabal' archiveSubdir bindir
|
||||
liftE $ installCabal' workdir bindir
|
||||
pure ()
|
||||
|
||||
where
|
||||
@@ -195,8 +200,8 @@ installCabalBin bDls ver mpfReq = do
|
||||
-> Path Abs -- ^ Path to install to
|
||||
-> Excepts '[CopyError] m ()
|
||||
installCabal' path inst = do
|
||||
lift $ $(logInfo) [s|Installing cabal|]
|
||||
let cabalFile = [rel|cabal|] :: Path Rel
|
||||
lift $ $(logInfo) "Installing cabal"
|
||||
let cabalFile = [rel|cabal|]
|
||||
liftIO $ createDirIfMissing newDirPerms inst
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> cabalFile)
|
||||
@@ -247,7 +252,7 @@ setGHC ver sghc = do
|
||||
SetGHCOnly -> pure file
|
||||
SetGHC_XY -> do
|
||||
major' <-
|
||||
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
|
||||
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> "." <> intToText mi)
|
||||
<$> getGHCMajor ver
|
||||
parseRel (toFilePath file <> B.singleton _hyphen <> major')
|
||||
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
@@ -273,11 +278,11 @@ setGHC ver sghc = do
|
||||
destdir <- liftIO $ ghcupBaseDir
|
||||
case sghc of
|
||||
SetGHCOnly -> do
|
||||
let sharedir = [rel|share|] :: Path Rel
|
||||
let sharedir = [rel|share|]
|
||||
let fullsharedir = ghcdir </> sharedir
|
||||
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
|
||||
let fullF = destdir </> sharedir
|
||||
let targetF = [s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir
|
||||
let targetF = "./ghc/" <> verBS <> "/" <> toFilePath sharedir
|
||||
$(logDebug) [i|rm -f #{fullF}|]
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
|
||||
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
|
||||
@@ -335,12 +340,12 @@ listVersions av lt criteria = case lt of
|
||||
fromSrc <- ghcSrcInstalled v
|
||||
pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
|
||||
Cabal -> do
|
||||
lSet <- fmap (== v) $ cabalSet
|
||||
lInstalled <- cabalInstalled v
|
||||
lSet <- fmap (== v) $ cabalSet
|
||||
let lInstalled = lSet
|
||||
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
|
||||
GHCup -> do
|
||||
let lSet = prettyPVP ghcUpVer == prettyVer v
|
||||
let lInstalled = True
|
||||
let lInstalled = lSet
|
||||
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
|
||||
|
||||
|
||||
@@ -393,7 +398,7 @@ rmGHCVer ver = do
|
||||
$ ghcupBaseDir
|
||||
>>= hideError doesNotExistErrorType
|
||||
. deleteFile
|
||||
. (</> ([rel|share|] :: Path Rel))
|
||||
. (</> [rel|share|])
|
||||
else throwE (NotInstalled GHC ver)
|
||||
|
||||
|
||||
@@ -404,19 +409,18 @@ rmGHCVer ver = do
|
||||
------------------
|
||||
|
||||
|
||||
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
|
||||
getDebugInfo :: (MonadLogger m, MonadCatch 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
|
||||
diBaseDir <- liftIO $ ghcupBaseDir
|
||||
diBinDir <- liftIO $ ghcupBinDir
|
||||
diGHCDir <- liftIO $ ghcupGHCBaseDir
|
||||
diCacheDir <- liftIO $ ghcupCacheDir
|
||||
diArch <- lE getArchitecture
|
||||
diPlatform <- liftE $ getPlatform
|
||||
pure $ DebugInfo { .. }
|
||||
|
||||
|
||||
@@ -436,23 +440,29 @@ compileGHC :: ( MonadMask m
|
||||
, MonadFail m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version -- ^ version to install
|
||||
-> Version -- ^ version to bootstrap with
|
||||
-> Maybe Int -- ^ jobs
|
||||
-> Maybe (Path Abs) -- ^ build config
|
||||
-> Version -- ^ version to install
|
||||
-> Either Version (Path Abs) -- ^ version to bootstrap with
|
||||
-> Maybe Int -- ^ jobs
|
||||
-> Maybe (Path Abs) -- ^ build config
|
||||
-> Maybe (Path Abs)
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, GHCupSetError
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
, NotFoundInPATH
|
||||
, PatchFailed
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
compileGHC dls tver bver jobs mbuildConfig = do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
|
||||
compileGHC dls tver bstrap jobs mbuildConfig patchdir = do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
|
||||
whenM (liftIO $ toolAlreadyInstalled GHC tver)
|
||||
(throwE $ AlreadyInstalled GHC tver)
|
||||
|
||||
@@ -463,16 +473,24 @@ compileGHC dls tver bver jobs mbuildConfig = do
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
(PlatformRequest {..}) <- liftE $ platformRequest
|
||||
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
||||
|
||||
bghc <- parseRel ([s|ghc-|] <> verToBS bver)
|
||||
bghc <- case bstrap of
|
||||
Right g -> pure $ Right g
|
||||
Left bver -> Left <$> parseRel ("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)
|
||||
)
|
||||
-- Be careful about cleanup. We must catch both pure exceptions
|
||||
-- as well as async ones.
|
||||
flip onException
|
||||
(liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
|
||||
$ catchAllE
|
||||
(\es ->
|
||||
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
|
||||
>> throwE (BuildFailed workdir es)
|
||||
)
|
||||
$ compile bghc ghcdir workdir
|
||||
markSrcBuilt ghcdir workdir
|
||||
|
||||
@@ -492,36 +510,49 @@ HADDOCK_DOCS = YES
|
||||
GhcWithLlvmCodeGen = YES|]
|
||||
|
||||
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
|
||||
=> Path Rel
|
||||
=> Either (Path Rel) (Path Abs)
|
||||
-> Path Abs
|
||||
-> Path Abs
|
||||
-> Excepts
|
||||
'[NoDownload , FileDoesNotExistError , ProcessError]
|
||||
'[ FileDoesNotExistError
|
||||
, PatchFailed
|
||||
, ProcessError
|
||||
, NotFoundInPATH
|
||||
]
|
||||
m
|
||||
()
|
||||
compile bghc ghcdir workdir = do
|
||||
lift $ $(logInfo) [i|configuring build|]
|
||||
|
||||
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
|
||||
|
||||
-- force ld.bfd for build (others seem to misbehave, like lld from FreeBSD)
|
||||
newEnv <- addToCurrentEnv [("LD", "ld.bfd")]
|
||||
|
||||
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)
|
||||
bghcPath <- case bghc of
|
||||
Right ghc' -> pure ghc'
|
||||
Left bver -> do
|
||||
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
|
||||
(liftIO $ searchPath spaths bver) !? NotFoundInPATH bver
|
||||
lEM $ liftIO $ execLogged
|
||||
"./configure"
|
||||
False
|
||||
["--prefix=" <> toFilePath ghcdir]
|
||||
[rel|ghc-conf|]
|
||||
(Just workdir)
|
||||
(Just (("GHC", toFilePath bghcPath) : newEnv))
|
||||
| otherwise -> do
|
||||
lEM $ liftIO $ execLogged
|
||||
[s|./configure|]
|
||||
"./configure"
|
||||
False
|
||||
[ [s|--prefix=|] <> toFilePath ghcdir
|
||||
, [s|--with-ghc=|] <> toFilePath bghc
|
||||
[ "--prefix=" <> toFilePath ghcdir
|
||||
, "--with-ghc=" <> either toFilePath toFilePath bghc
|
||||
]
|
||||
([rel|ghc-configure.log|] :: Path Rel)
|
||||
[rel|ghc-conf|]
|
||||
(Just workdir)
|
||||
Nothing
|
||||
(Just newEnv)
|
||||
|
||||
case mbuildConfig of
|
||||
Just bc -> liftIOException
|
||||
@@ -531,29 +562,18 @@ GhcWithLlvmCodeGen = YES|]
|
||||
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|Building (this may take a while)...|]
|
||||
lEM $ liftIO $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
|
||||
(Just workdir)
|
||||
|
||||
lift $ $(logInfo) [i|Installing...|]
|
||||
lEM $ liftIO $ execLogged [s|make|]
|
||||
True
|
||||
[[s|install|]]
|
||||
([rel|ghc-make.log|] :: Path Rel)
|
||||
(Just workdir)
|
||||
Nothing
|
||||
lEM $ liftIO $ make ["install"] (Just workdir)
|
||||
|
||||
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)
|
||||
build_mk workdir = workdir </> [rel|mk/build.mk|]
|
||||
|
||||
|
||||
compileCabal :: ( MonadReader Settings m
|
||||
@@ -564,19 +584,24 @@ compileCabal :: ( MonadReader Settings m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Version -- ^ version to install
|
||||
-> Version -- ^ GHC version to build with
|
||||
-> Either Version (Path Abs) -- ^ version to bootstrap with
|
||||
-> Maybe Int
|
||||
-> Maybe (Path Abs)
|
||||
-> Excepts
|
||||
'[ BuildFailed
|
||||
, DigestError
|
||||
, DistroNotFound
|
||||
, DownloadFailed
|
||||
, NoCompatibleArch
|
||||
, NoCompatiblePlatform
|
||||
, NoDownload
|
||||
, PatchFailed
|
||||
, UnknownArchive
|
||||
]
|
||||
m
|
||||
()
|
||||
compileCabal dls tver bver jobs = do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bver}|]
|
||||
compileCabal dls tver bghc jobs patchdir = do
|
||||
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
|
||||
|
||||
-- download source tarball
|
||||
dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
|
||||
@@ -585,6 +610,8 @@ compileCabal dls tver bver jobs = do
|
||||
-- unpack
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
liftE $ unpackToDir tmpUnpack dl
|
||||
(PlatformRequest {..}) <- liftE $ platformRequest
|
||||
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
|
||||
|
||||
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
|
||||
|
||||
@@ -596,27 +623,38 @@ compileCabal dls tver bver jobs = do
|
||||
pure ()
|
||||
|
||||
where
|
||||
compile :: (MonadLogger m, MonadIO m)
|
||||
compile :: (MonadThrow m, MonadLogger m, MonadIO m)
|
||||
=> Path Abs
|
||||
-> Excepts '[ProcessError] m ()
|
||||
-> Excepts '[ProcessError , PatchFailed] 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.|]
|
||||
lift $ $(logInfo) [i|Building (this may take a while)...|]
|
||||
|
||||
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
|
||||
|
||||
ghcEnv <- case bghc of
|
||||
Right path -> do
|
||||
-- recover the version from /foo/ghc-6.5.4
|
||||
bn <- basename path
|
||||
let dn = toFilePath $ dirname path
|
||||
let ver = snd . B.break (== _hyphen) . toFilePath $ bn
|
||||
|
||||
pure
|
||||
[ ("GHC" , toFilePath path)
|
||||
, ("GHC_PKG", dn <> "/" <> "ghc-pkg" <> ver)
|
||||
]
|
||||
Left bver -> do
|
||||
let v' = verToBS bver
|
||||
pure [("GHC", "ghc-" <> v'), ("GHC_PKG", "ghc-pkg-" <> v')]
|
||||
|
||||
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)
|
||||
]
|
||||
newEnv <- lift
|
||||
$ addToCurrentEnv (("PREFIX", toFilePath cabal_bin) : ghcEnv)
|
||||
lift $ $(logDebug) [i|Environment: #{newEnv}|]
|
||||
|
||||
lEM $ liftIO $ execLogged [s|./bootstrap.sh|]
|
||||
lEM $ liftIO $ execLogged "./bootstrap.sh"
|
||||
False
|
||||
(maybe [] (\j -> [[s|-j|], fS (show j)]) jobs)
|
||||
([rel|cabal-bootstrap.log|] :: Path Rel)
|
||||
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
|
||||
[rel|cabal-bootstrap|]
|
||||
(Just workdir)
|
||||
(Just newEnv)
|
||||
|
||||
@@ -651,18 +689,31 @@ upgradeGHCup :: ( MonadMask 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
|
||||
let latestVer = fromJust $ getLatest dls GHCup
|
||||
pfreq <- liftE platformRequest
|
||||
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
|
||||
tmp <- lift withGHCupTmpDir
|
||||
let fn = [rel|ghcup|]
|
||||
p <- liftE $ download dli tmp (Just fn)
|
||||
let fileMode' =
|
||||
newFilePerms
|
||||
`unionFileModes` ownerExecuteMode
|
||||
`unionFileModes` groupExecuteMode
|
||||
`unionFileModes` otherExecuteMode
|
||||
case mtarget of
|
||||
Nothing -> do
|
||||
dest <- liftIO $ ghcupBinDir
|
||||
liftIO $ hideError NoSuchThing $ deleteFile (dest </> fn)
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||
(dest </> fn)
|
||||
Overwrite
|
||||
Just fullDest -> liftIO $ copyFile p fullDest Overwrite
|
||||
liftIO $ setFileMode (toFilePath (dest </> fn)) fileMode'
|
||||
Just fullDest -> do
|
||||
liftIO $ hideError NoSuchThing $ deleteFile fullDest
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||
fullDest
|
||||
Overwrite
|
||||
liftIO $ setFileMode (toFilePath fullDest) fileMode'
|
||||
pure latestVer
|
||||
|
||||
|
||||
|
||||
@@ -1,84 +1,79 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
module GHCup.Download where
|
||||
|
||||
|
||||
#if !defined(CURL)
|
||||
import GHCup.Download.IOStreams
|
||||
import GHCup.Download.Utils
|
||||
#endif
|
||||
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.Version
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
import Data.Aeson
|
||||
#if !defined(CURL)
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.ByteString.Builder
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import Data.IORef
|
||||
#endif
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Text.Read
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.POSIX
|
||||
#if !defined(CURL)
|
||||
import Data.Time.Format
|
||||
#endif
|
||||
import Data.Versions
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import HPath.IO as HIO
|
||||
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 Crypto.Hash.SHA256 as SHA256
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
#if !defined(CURL)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
#endif
|
||||
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|]
|
||||
|
||||
|
||||
|
||||
@@ -93,21 +88,20 @@ getDownloads :: ( FromJSONKey Tool
|
||||
, 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
|
||||
=> URLSource
|
||||
-> Excepts '[JSONError , DownloadFailed] m GHCupInfo
|
||||
getDownloads urlSource = do
|
||||
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
|
||||
case urlSource of
|
||||
GHCupURL -> do
|
||||
bs <- reThrowAll DownloadFailed $ dl ghcupURL
|
||||
bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSource url) -> do
|
||||
bs <- reThrowAll DownloadFailed $ dl url
|
||||
bs <- reThrowAll DownloadFailed $ downloadBS url
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSpec av) -> pure $ av
|
||||
|
||||
@@ -121,24 +115,25 @@ getDownloads = do
|
||||
-- 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
|
||||
smartDl :: forall m1
|
||||
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
, ProcessError
|
||||
]
|
||||
m1
|
||||
L.ByteString
|
||||
smartDl uri' = do
|
||||
let path = view pathL' uri'
|
||||
json_file <- (liftIO $ ghcupCacheDir)
|
||||
>>= \cacheDir -> (cacheDir </>) <$> urlBaseName path
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
cacheDir <- liftIO $ ghcupCacheDir
|
||||
json_file <- (cacheDir </>) <$> urlBaseName path
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
if e
|
||||
then do
|
||||
accessTime <-
|
||||
@@ -159,23 +154,27 @@ getDownloads = do
|
||||
pure bs
|
||||
else liftIO $ readFile json_file
|
||||
Nothing -> do
|
||||
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
|
||||
lift $ $(logDebug) [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
|
||||
liftIO $ createDirIfMissing newDirPerms cacheDir
|
||||
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|]
|
||||
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
|
||||
liftE $ downloadBS uri'
|
||||
|
||||
where
|
||||
getModTime = do
|
||||
#if defined(CURL)
|
||||
pure Nothing
|
||||
#else
|
||||
headers <-
|
||||
handleIO (\_ -> pure mempty)
|
||||
$ liftE
|
||||
@@ -187,15 +186,16 @@ getDownloads = do
|
||||
)
|
||||
pure $ parseModifiedHeader headers
|
||||
|
||||
|
||||
parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
|
||||
parseModifiedHeader headers =
|
||||
(M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM
|
||||
(M.lookup (CI.mk "Last-Modified") headers) >>= \h -> parseTimeM
|
||||
True
|
||||
defaultTimeLocale
|
||||
"%a, %d %b %Y %H:%M:%S %Z"
|
||||
(T.unpack . E.decodeUtf8 $ h)
|
||||
|
||||
#endif
|
||||
|
||||
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
|
||||
writeFileWithModTime utctime path content = do
|
||||
let mod_time = utcTimeToPOSIXSeconds utctime
|
||||
@@ -203,47 +203,13 @@ getDownloads = do
|
||||
setModificationTimeHiRes path mod_time
|
||||
|
||||
|
||||
|
||||
getDownloadInfo :: ( MonadLogger m
|
||||
, MonadCatch m
|
||||
, MonadIO m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> Tool
|
||||
getDownloadInfo :: 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
|
||||
-> PlatformRequest
|
||||
-> GHCupDownloads
|
||||
-> Either NoDownload DownloadInfo
|
||||
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
|
||||
(Left NoDownload)
|
||||
Right
|
||||
(with_distro <|> without_distro_ver <|> without_distro)
|
||||
@@ -275,9 +241,9 @@ download :: ( MonadMask m
|
||||
-> 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
|
||||
| scheme == "https" = dl
|
||||
| scheme == "http" = dl
|
||||
| scheme == "file" = cp
|
||||
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
|
||||
|
||||
where
|
||||
@@ -293,19 +259,25 @@ download dli dest mfn
|
||||
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
|
||||
flip onException
|
||||
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
|
||||
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
|
||||
(\e ->
|
||||
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
|
||||
>> (throwE . DownloadFailed $ e)
|
||||
) $ do
|
||||
#if defined(CURL)
|
||||
liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
|
||||
["-fL", "-o", toFilePath destFile , serializeURIRef' $ view dlUri dli] Nothing Nothing
|
||||
#else
|
||||
(https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
|
||||
liftE $ downloadToFile https host fullPath port destFile
|
||||
#endif
|
||||
|
||||
liftE $ checkDigest dli destFile
|
||||
pure destFile
|
||||
@@ -354,6 +326,8 @@ downloadCached dli mfn = do
|
||||
------------------
|
||||
|
||||
|
||||
|
||||
|
||||
-- | This is used for downloading the JSON.
|
||||
downloadBS :: (MonadCatch m, MonadIO m)
|
||||
=> URI
|
||||
@@ -364,15 +338,16 @@ downloadBS :: (MonadCatch m, MonadIO m)
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
, ProcessError
|
||||
]
|
||||
m
|
||||
L.ByteString
|
||||
downloadBS uri'
|
||||
| scheme == [s|https|]
|
||||
| scheme == "https"
|
||||
= dl True
|
||||
| scheme == [s|http|]
|
||||
| scheme == "http"
|
||||
= dl False
|
||||
| scheme == [s|file|]
|
||||
| scheme == "file"
|
||||
= liftIOException doesNotExistErrorType (FileDoesNotExistError path)
|
||||
$ (liftIO $ RD.readFile path)
|
||||
| otherwise
|
||||
@@ -381,223 +356,19 @@ downloadBS uri'
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
path = view pathL' uri'
|
||||
#if defined(CURL)
|
||||
dl _ = do
|
||||
let exe = [rel|curl|]
|
||||
args = ["-sSfL", serializeURIRef' uri']
|
||||
liftIO (executeOut exe args Nothing) >>= \case
|
||||
CapturedProcess ExitSuccess stdout _ -> do
|
||||
pure $ L.fromStrict stdout
|
||||
CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
|
||||
#else
|
||||
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
|
||||
#endif
|
||||
|
||||
|
||||
checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m)
|
||||
@@ -608,8 +379,9 @@ checkDigest dli file = do
|
||||
verify <- lift ask <&> (not . noVerify)
|
||||
when verify $ do
|
||||
let p' = toFilePath file
|
||||
lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
|
||||
lift $ $(logInfo) [i|verifying digest of: #{p'}|]
|
||||
c <- liftIO $ readFile file
|
||||
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
|
||||
let cDigest = E.decodeUtf8 . B16.encode . SHA256.hashlazy $ c
|
||||
eDigest = view dlHash dli
|
||||
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
|
||||
|
||||
|
||||
254
lib/GHCup/Download/IOStreams.hs
Normal file
254
lib/GHCup/Download/IOStreams.hs
Normal file
@@ -0,0 +1,254 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
module GHCup.Download.IOStreams where
|
||||
|
||||
|
||||
import GHCup.Download.Utils
|
||||
import GHCup.Errors
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.File
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.ByteString.Builder
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.Text.Read
|
||||
import HPath
|
||||
import HPath.IO as HIO
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Network.Http.Client hiding ( URL )
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( fdWrite )
|
||||
import "unix-bytestring" System.Posix.IO.ByteString
|
||||
( fdWrite )
|
||||
import System.ProgressBar
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified System.IO.Streams as Streams
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
----------------------------
|
||||
--[ Low-level (non-curl) ]--
|
||||
----------------------------
|
||||
|
||||
|
||||
-- | 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)
|
||||
|
||||
|
||||
downloadToFile :: (MonadMask m, 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)
|
||||
-> Path Abs -- ^ destination file to create and write to
|
||||
-> Excepts '[DownloadFailed] m ()
|
||||
downloadToFile https host fullPath port destFile = do
|
||||
fd <- liftIO $ createRegularFileFd newFilePerms destFile
|
||||
let stepper = fdWrite fd
|
||||
flip finally (liftIO $ closeFd fd)
|
||||
$ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper
|
||||
|
||||
|
||||
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 "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 "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
|
||||
, ProcessError
|
||||
]
|
||||
m
|
||||
(M.Map (CI ByteString) ByteString)
|
||||
getHead uri' | scheme == "https" = head' True
|
||||
| scheme == "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 "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)
|
||||
64
lib/GHCup/Download/Utils.hs
Normal file
64
lib/GHCup/Download/Utils.hs
Normal file
@@ -0,0 +1,64 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
module GHCup.Download.Utils where
|
||||
|
||||
|
||||
import GHCup.Errors
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.Binary.Builder as B
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
|
||||
-- | 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 == "https" -> pure True
|
||||
| scheme == "http" -> pure False
|
||||
| otherwise -> throwE UnsupportedScheme
|
||||
|
||||
let queryBS =
|
||||
BS.intercalate "&"
|
||||
. fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y)
|
||||
$ (queryPairs uriQuery)
|
||||
port =
|
||||
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
|
||||
fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS
|
||||
pure (https, host, fullpath, port)
|
||||
where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery
|
||||
|
||||
@@ -63,6 +63,10 @@ data AlreadyInstalled = AlreadyInstalled Tool Version
|
||||
data NotInstalled = NotInstalled Tool Version
|
||||
deriving Show
|
||||
|
||||
-- | An executable was expected to be in PATH, but was not found.
|
||||
data NotFoundInPATH = NotFoundInPATH (Path Rel)
|
||||
deriving Show
|
||||
|
||||
-- | JSON decoding failed.
|
||||
data JSONError = JSONDecodeError String
|
||||
deriving Show
|
||||
@@ -88,6 +92,13 @@ data NoLocationHeader = NoLocationHeader
|
||||
data TooManyRedirs = TooManyRedirs
|
||||
deriving Show
|
||||
|
||||
-- | A patch could not be applied.
|
||||
data PatchFailed = PatchFailed
|
||||
deriving Show
|
||||
|
||||
-- | The tool requirements could not be found.
|
||||
data NoToolRequirements = NoToolRequirements
|
||||
deriving Show
|
||||
|
||||
|
||||
-------------------------
|
||||
|
||||
@@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
@@ -20,7 +22,7 @@ import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
@@ -34,16 +36,31 @@ import Prelude hiding ( abs
|
||||
, writeFile
|
||||
)
|
||||
import System.Info
|
||||
import Text.Regex.Posix
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.ICU as ICU
|
||||
|
||||
--------------------------
|
||||
--[ Platform detection ]--
|
||||
--------------------------
|
||||
|
||||
|
||||
-- | Get the full platform request, consisting of architecture, distro, ...
|
||||
platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
'[ NoCompatiblePlatform
|
||||
, NoCompatibleArch
|
||||
, DistroNotFound
|
||||
]
|
||||
m
|
||||
PlatformRequest
|
||||
platformRequest = do
|
||||
(PlatformResult rp rv) <- liftE getPlatform
|
||||
ar <- lE getArchitecture
|
||||
pure $ PlatformRequest ar rp rv
|
||||
|
||||
|
||||
getArchitecture :: Either NoCompatibleArch Architecture
|
||||
getArchitecture = case arch of
|
||||
"x86_64" -> Right A_64
|
||||
@@ -62,16 +79,30 @@ getPlatform = do
|
||||
"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 }
|
||||
"darwin" -> do
|
||||
ver <-
|
||||
( either (const Nothing) Just
|
||||
. versioning
|
||||
. getMajorVersion
|
||||
. E.decodeUtf8
|
||||
)
|
||||
<$> getDarwinVersion
|
||||
pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
|
||||
"freebsd" -> do
|
||||
ver <- getFreeBSDVersion
|
||||
ver <-
|
||||
(either (const Nothing) Just . versioning . E.decodeUtf8)
|
||||
<$> getFreeBSDVersion
|
||||
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
||||
what -> throwE $ NoCompatiblePlatform what
|
||||
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
|
||||
pure pfr
|
||||
where getFreeBSDVersion = pure Nothing
|
||||
where
|
||||
getMajorVersion = T.intercalate "." . take 2 . T.split (== '.')
|
||||
getFreeBSDVersion =
|
||||
liftIO $ fmap _stdOut $ executeOut [rel|freebsd-version|] [] Nothing
|
||||
getDarwinVersion = liftIO $ fmap _stdOut $ executeOut [rel|sw_vers|]
|
||||
["-productVersion"]
|
||||
Nothing
|
||||
|
||||
|
||||
getLinuxDistro :: (MonadCatch m, MonadIO m)
|
||||
@@ -100,16 +131,11 @@ getLinuxDistro = do
|
||||
| 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)
|
||||
hasWord t matches = foldr (\x y -> match (regex x) (T.unpack t) || y)
|
||||
False
|
||||
matches
|
||||
where
|
||||
regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
|
||||
|
||||
os_release :: Path Abs
|
||||
os_release = [abs|/etc/os-release|]
|
||||
@@ -131,8 +157,8 @@ getLinuxDistro = do
|
||||
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
|
||||
name <- fmap _stdOut $ executeOut lsb_release_cmd ["-si"] Nothing
|
||||
ver <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
|
||||
pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
|
||||
|
||||
try_lsb_release :: IO (Text, Maybe Text)
|
||||
@@ -144,21 +170,24 @@ getLinuxDistro = do
|
||||
try_redhat_release :: IO (Text, Maybe Text)
|
||||
try_redhat_release = do
|
||||
t <- fmap lBS2sT $ readFile redhat_release
|
||||
let nameRegex n =
|
||||
makeRegexOpts compIgnoreCase
|
||||
execBlank
|
||||
(([s|\<|] <> fS n <> [s|\>|] :: ByteString)) :: Regex
|
||||
let verRegex =
|
||||
makeRegexOpts compIgnoreCase
|
||||
execBlank
|
||||
([s|\<([0-9])+(.([0-9])+)*\>|] :: ByteString) :: Regex
|
||||
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
|
||||
fromEmpty . match (nameRegex n) $ T.unpack t :: Maybe String
|
||||
verRe = fromEmpty . match verRegex $ T.unpack t :: Maybe String
|
||||
(Just name) <- pure
|
||||
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
|
||||
pure (name, verRe)
|
||||
pure (T.pack name, fmap T.pack verRe)
|
||||
where
|
||||
fromEmpty :: String -> Maybe String
|
||||
fromEmpty "" = Nothing
|
||||
fromEmpty s' = Just s'
|
||||
|
||||
try_debian_version :: IO (Text, Maybe Text)
|
||||
try_debian_version = do
|
||||
|
||||
46
lib/GHCup/Requirements.hs
Normal file
46
lib/GHCup/Requirements.hs
Normal file
@@ -0,0 +1,46 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module GHCup.Requirements where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Maybe
|
||||
import Optics
|
||||
import Prelude hiding ( abs
|
||||
, readFile
|
||||
, writeFile
|
||||
)
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
|
||||
-- | Get the requirements. Right now this combines GHC and cabal
|
||||
-- and doesn't do fine-grained distinction. However, the 'ToolRequirements'
|
||||
-- type allows it.
|
||||
getCommonRequirements :: PlatformResult
|
||||
-> ToolRequirements
|
||||
-> Maybe Requirements
|
||||
getCommonRequirements pr tr =
|
||||
preview (ix GHC % ix Nothing % ix (_platform pr) % ix (_distroVersion pr)) tr
|
||||
<|> preview (ix GHC % ix Nothing % ix (_platform pr) % ix Nothing) tr
|
||||
<|> preview
|
||||
( ix GHC
|
||||
% ix Nothing
|
||||
% ix (set _Linux UnknownLinux $ _platform pr)
|
||||
% ix Nothing
|
||||
)
|
||||
tr
|
||||
|
||||
|
||||
prettyRequirements :: Requirements -> T.Text
|
||||
prettyRequirements Requirements {..} =
|
||||
let d = if not . null $ _distroPKGs
|
||||
then
|
||||
"\n Install the following distro packages: "
|
||||
<> T.intercalate " " _distroPKGs
|
||||
else ""
|
||||
n = if not . T.null $ _notes then "\n Note: " <> _notes else ""
|
||||
in "System requirements " <> d <> n
|
||||
@@ -12,6 +12,39 @@ import qualified GHC.Generics as GHC
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
--[ GHCInfo Tree ]--
|
||||
--------------------
|
||||
|
||||
|
||||
data GHCupInfo = GHCupInfo
|
||||
{ _toolRequirements :: ToolRequirements
|
||||
, _ghcupDownloads :: GHCupDownloads
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ Requirements Tree ]--
|
||||
-------------------------
|
||||
|
||||
|
||||
type ToolRequirements = Map Tool ToolReqVersionSpec
|
||||
type ToolReqVersionSpec = Map (Maybe Version) PlatformReqSpec
|
||||
type PlatformReqSpec = Map Platform PlatformReqVersionSpec
|
||||
type PlatformReqVersionSpec = Map (Maybe Versioning) Requirements
|
||||
|
||||
|
||||
data Requirements = Requirements
|
||||
{ _distroPKGs :: [Text]
|
||||
, _notes :: Text
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--[ Download Tree ]--
|
||||
@@ -99,26 +132,24 @@ data DownloadInfo = DownloadInfo
|
||||
-- | Where to fetch GHCupDownloads from.
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource URI
|
||||
| OwnSpec GHCupDownloads
|
||||
| OwnSpec GHCupInfo
|
||||
deriving Show
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
, urlSource :: URLSource
|
||||
, noVerify :: Bool
|
||||
{ cache :: Bool
|
||||
, 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
|
||||
{ diBaseDir :: Path Abs
|
||||
, diBinDir :: Path Abs
|
||||
, diGHCDir :: Path Abs
|
||||
, diCacheDir :: Path Abs
|
||||
, diArch :: Architecture
|
||||
, diPlatform :: PlatformResult
|
||||
}
|
||||
deriving Show
|
||||
|
||||
@@ -141,4 +172,3 @@ data PlatformRequest = PlatformRequest
|
||||
, _rVersion :: Maybe Versioning
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
@@ -13,12 +14,10 @@ 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
|
||||
@@ -40,6 +39,8 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
|
||||
|
||||
|
||||
instance ToJSON URI where
|
||||
@@ -70,11 +71,11 @@ instance FromJSONKey Versioning where
|
||||
instance ToJSONKey (Maybe Versioning) where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Just x -> prettyV x
|
||||
Nothing -> T.pack "unknown_version"
|
||||
Nothing -> T.pack "unknown_versioning"
|
||||
|
||||
instance FromJSONKey (Maybe Versioning) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
|
||||
if t == T.pack "unknown_versioning" then pure Nothing else pure $ just t
|
||||
where
|
||||
just t = case versioning t of
|
||||
Right x -> pure x
|
||||
@@ -113,6 +114,19 @@ instance ToJSONKey Architecture where
|
||||
instance FromJSONKey Architecture where
|
||||
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance ToJSONKey (Maybe Version) where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Just x -> prettyVer x
|
||||
Nothing -> T.pack "unknown_version"
|
||||
|
||||
instance FromJSONKey (Maybe Version) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
|
||||
where
|
||||
just t = case version t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSON Version where
|
||||
toJSON = toJSON . prettyVer
|
||||
|
||||
@@ -138,7 +152,7 @@ instance FromJSONKey Tool where
|
||||
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|]
|
||||
False -> String "/not/a/valid/path"
|
||||
where fp = toFilePath p
|
||||
|
||||
instance FromJSON (Path Rel) where
|
||||
|
||||
@@ -19,6 +19,7 @@ makeLenses ''DownloadInfo
|
||||
makeLenses ''Tag
|
||||
makeLenses ''VersionInfo
|
||||
|
||||
makeLenses ''GHCupInfo
|
||||
|
||||
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
|
||||
uriSchemeL' = lensVL uriSchemeL
|
||||
|
||||
@@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
@@ -17,15 +19,15 @@ 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
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
#endif
|
||||
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
|
||||
@@ -44,7 +46,9 @@ import Prelude hiding ( abs
|
||||
)
|
||||
import Safe
|
||||
import System.IO.Error
|
||||
import System.Posix.FilePath ( takeFileName )
|
||||
import System.Posix.FilePath ( getSearchPath
|
||||
, takeFileName
|
||||
)
|
||||
import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
import URI.ByteString
|
||||
|
||||
@@ -70,14 +74,14 @@ import qualified Data.Text.Encoding as E
|
||||
ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
|
||||
-> Version
|
||||
-> ByteString
|
||||
ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
|
||||
ghcLinkDestination tool ver = "../ghc/" <> verToBS ver <> "/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|]
|
||||
parser = string "../ghc/" *> verParser <* string "/bin/ghc"
|
||||
verParser = many1' (notWord8 _slash) >>= \t ->
|
||||
case version $ E.decodeUtf8 $ B.pack t of
|
||||
Left e -> fail $ show e
|
||||
@@ -90,7 +94,7 @@ rmMinorSymlinks ver = do
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
let myfiles =
|
||||
filter (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x) files
|
||||
filter (\x -> ("-" <> verToBS ver) `B.isSuffixOf` toFilePath x) files
|
||||
forM_ myfiles $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
@@ -117,12 +121,12 @@ rmPlain ver = do
|
||||
rmMajorSymlinks :: (MonadLogger m, MonadIO m) => Version -> m ()
|
||||
rmMajorSymlinks ver = do
|
||||
(mj, mi) <- liftIO $ getGHCMajor ver
|
||||
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
|
||||
let v' = E.encodeUtf8 $ intToText mj <> "." <> intToText mi
|
||||
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
files <- liftIO $ getDirsFiles' bindir
|
||||
let myfiles = filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
|
||||
let myfiles = filter (\x -> ("-" <> v') `B.isSuffixOf` toFilePath x) files
|
||||
forM_ myfiles $ \f -> do
|
||||
let fullF = (bindir </> f)
|
||||
$(logDebug) [i|rm -f #{toFilePath fullF}|]
|
||||
@@ -157,7 +161,7 @@ ghcSrcInstalled ver = do
|
||||
|
||||
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
|
||||
ghcSet = do
|
||||
ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
ghcBin <- (</> [rel|ghc|]) <$> liftIO ghcupBinDir
|
||||
|
||||
-- link destination is of the form ../ghc/<ver>/bin/ghc
|
||||
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
|
||||
@@ -172,8 +176,8 @@ cabalInstalled ver = do
|
||||
|
||||
cabalSet :: (MonadIO m, MonadThrow m) => m Version
|
||||
cabalSet = do
|
||||
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> liftIO ghcupBinDir
|
||||
mc <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
|
||||
cabalbin <- (</> [rel|cabal|]) <$> liftIO ghcupBinDir
|
||||
mc <- liftIO $ executeOut cabalbin ["--numeric-version"] Nothing
|
||||
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
|
||||
case version (E.decodeUtf8 reportedVer) of
|
||||
Left e -> throwM e
|
||||
@@ -235,15 +239,15 @@ unpackToDir dest av = do
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
|
||||
| ".tar.gz" `B.isSuffixOf` fn -> liftIO
|
||||
(untar . GZip.decompress =<< readFile av)
|
||||
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
|
||||
| ".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
|
||||
| ".tar.bz2" `B.isSuffixOf` fn -> liftIO
|
||||
(untar . BZip.decompress =<< readFile av)
|
||||
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
|
||||
| ".tar" `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
|
||||
@@ -277,9 +281,6 @@ getRecommended av tool = headOf folded $ getTagged av tool Recommended
|
||||
-----------------------
|
||||
|
||||
|
||||
getUrlSource :: MonadReader Settings m => m URLSource
|
||||
getUrlSource = ask <&> urlSource
|
||||
|
||||
getCache :: MonadReader Settings m => m Bool
|
||||
getCache = ask <&> cache
|
||||
|
||||
@@ -296,7 +297,7 @@ urlBaseName :: MonadThrow m
|
||||
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
|
||||
|
||||
|
||||
-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
|
||||
-- Get tool files from '~/.ghcup/bin/ghc/<ver>/bin/*'
|
||||
-- while ignoring *-<ver> symlinks.
|
||||
--
|
||||
-- Returns unversioned relative files, e.g.:
|
||||
@@ -316,7 +317,7 @@ ghcToolFiles ver = do
|
||||
-- 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)
|
||||
(B.stripPrefix "ghc-" . takeFileName)
|
||||
<$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> [rel|ghc|]))
|
||||
when (B.null symver)
|
||||
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
|
||||
@@ -328,3 +329,42 @@ ghcToolFiles ver = do
|
||||
-- this GHC was built from source. It contains the build config.
|
||||
ghcUpSrcBuiltFile :: Path Rel
|
||||
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
|
||||
|
||||
|
||||
-- | Calls gmake if it exists in PATH, otherwise make.
|
||||
make :: [ByteString] -> Maybe (Path Abs) -> IO (Either ProcessError ())
|
||||
make args workdir = do
|
||||
spaths <- catMaybes . fmap parseAbs <$> getSearchPath
|
||||
has_gmake <- isJust <$> searchPath spaths [rel|gmake|]
|
||||
let mymake = if has_gmake then "gmake" else "make"
|
||||
execLogged mymake True args [rel|ghc-make|] workdir Nothing
|
||||
|
||||
|
||||
-- | Try to apply patches in order. Fails with 'PatchFailed'
|
||||
-- on first failure.
|
||||
applyPatches :: (MonadLogger m, MonadIO m)
|
||||
=> Path Abs -- ^ dir containing patches
|
||||
-> Path Abs -- ^ dir to apply patches in
|
||||
-> Excepts '[PatchFailed] m ()
|
||||
applyPatches pdir ddir = do
|
||||
patches <- liftIO $ getDirsFiles pdir
|
||||
forM_ (sort patches) $ \patch' -> do
|
||||
lift $ $(logInfo) [i|Applying patch #{patch'}|]
|
||||
(fmap (either (const Nothing) Just) $ liftIO $ exec
|
||||
"patch"
|
||||
True
|
||||
["-p1", "-i", toFilePath patch']
|
||||
(Just ddir)
|
||||
Nothing
|
||||
)
|
||||
!? PatchFailed
|
||||
|
||||
|
||||
darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
|
||||
darwinNotarization Darwin path = exec
|
||||
"xattr"
|
||||
True
|
||||
["-r", "-d", "com.apple.quarantine", toFilePath path]
|
||||
Nothing
|
||||
Nothing
|
||||
darwinNotarization _ _ = pure $ Right ()
|
||||
|
||||
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module GHCup.Utils.Dirs where
|
||||
@@ -5,7 +6,6 @@ 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
|
||||
@@ -39,14 +39,14 @@ import qualified System.Posix.User as PU
|
||||
|
||||
ghcupBaseDir :: IO (Path Abs)
|
||||
ghcupBaseDir = do
|
||||
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
|
||||
getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||
Just r -> parseAbs r
|
||||
Nothing -> do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> ([rel|.ghcup|] :: Path Rel))
|
||||
pure (home </> [rel|.ghcup|])
|
||||
|
||||
ghcupGHCBaseDir :: IO (Path Abs)
|
||||
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
|
||||
ghcupGHCBaseDir = ghcupBaseDir <&> (</> [rel|ghc|])
|
||||
|
||||
ghcupGHCDir :: Version -> IO (Path Abs)
|
||||
ghcupGHCDir ver = do
|
||||
@@ -56,19 +56,19 @@ ghcupGHCDir ver = do
|
||||
|
||||
|
||||
ghcupBinDir :: IO (Path Abs)
|
||||
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
|
||||
ghcupBinDir = ghcupBaseDir <&> (</> [rel|bin|])
|
||||
|
||||
ghcupCacheDir :: IO (Path Abs)
|
||||
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
|
||||
ghcupCacheDir = ghcupBaseDir <&> (</> [rel|cache|])
|
||||
|
||||
ghcupLogsDir :: IO (Path Abs)
|
||||
ghcupLogsDir = ghcupBaseDir <&> (</> ([rel|logs|] :: Path Rel))
|
||||
ghcupLogsDir = ghcupBaseDir <&> (</> [rel|logs|])
|
||||
|
||||
|
||||
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
mkGhcupTmpDir = do
|
||||
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
|
||||
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
|
||||
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
|
||||
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> "ghcup-")
|
||||
parseAbs tmp
|
||||
|
||||
|
||||
@@ -83,7 +83,7 @@ withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
|
||||
|
||||
getHomeDirectory :: IO (Path Abs)
|
||||
getHomeDirectory = do
|
||||
e <- getEnv [s|HOME|]
|
||||
e <- getEnv "HOME"
|
||||
case e of
|
||||
Just fp -> parseAbs fp
|
||||
Nothing -> do
|
||||
|
||||
@@ -1,18 +1,22 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GHCup.Utils.File where
|
||||
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception ( evaluate )
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Data.ByteString
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
|
||||
import Data.Char
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import GHC.Foreign ( peekCStringLen )
|
||||
import GHC.IO.Encoding ( getLocaleEncoding )
|
||||
@@ -23,7 +27,10 @@ import Optics
|
||||
import Streamly
|
||||
import Streamly.External.ByteString
|
||||
import Streamly.External.ByteString.Lazy
|
||||
import System.Console.Pretty
|
||||
import System.Console.Regions
|
||||
import System.IO
|
||||
import System.IO.Error
|
||||
import System.Posix.Directory.ByteString
|
||||
import System.Posix.FD as FD
|
||||
import System.Posix.FilePath hiding ( (</>) )
|
||||
@@ -34,6 +41,10 @@ import System.Posix.Process ( ProcessStatus(..) )
|
||||
import System.Posix.Types
|
||||
|
||||
|
||||
import qualified Control.Exception as EX
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.Encoding.Error as E
|
||||
import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
import Streamly.External.Posix.DirStream
|
||||
@@ -42,7 +53,17 @@ import qualified Streamly.Internal.Memory.ArrayStream
|
||||
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 as BS
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified "unix-bytestring" System.Posix.IO.ByteString
|
||||
as SPIB
|
||||
|
||||
|
||||
-- | Bool signals whether the regions should be cleaned.
|
||||
data StopThread = StopThread Bool
|
||||
deriving Show
|
||||
|
||||
instance Exception StopThread
|
||||
|
||||
|
||||
data ProcessError = NonZeroExit Int ByteString [ByteString]
|
||||
@@ -99,7 +120,7 @@ findExecutable ex = do
|
||||
|
||||
-- | 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'
|
||||
executeOut :: Path b -- ^ command as filename, e.g. 'ls'
|
||||
-> [ByteString] -- ^ arguments to the command
|
||||
-> Maybe (Path Abs) -- ^ chdir to this path
|
||||
-> IO CapturedProcess
|
||||
@@ -116,26 +137,103 @@ execLogged :: ByteString -- ^ thing to execute
|
||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||
-> IO (Either ProcessError ())
|
||||
execLogged exe spath args lfile chdir env = do
|
||||
ldir <- ghcupLogsDir
|
||||
let logfile = ldir </> lfile
|
||||
ldir <- ghcupLogsDir
|
||||
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
|
||||
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
|
||||
where
|
||||
action fd = do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
-- dup stdout
|
||||
void $ dupTo fd stdOutput
|
||||
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
|
||||
-- start the thread that logs to stdout in a region
|
||||
done <- newEmptyMVar
|
||||
tid <-
|
||||
forkIO
|
||||
$ EX.handle (\(_ :: StopThread) -> pure ())
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ flip finally (putMVar done ())
|
||||
$ printToRegion fd stdoutRead 6
|
||||
|
||||
-- dup stderr
|
||||
void $ dupTo fd stdError
|
||||
-- fork our subprocess
|
||||
pid <- SPPB.forkProcess $ do
|
||||
void $ dupTo stdoutWrite stdOutput
|
||||
void $ dupTo stdoutWrite stdError
|
||||
closeFd stdoutWrite
|
||||
closeFd stdoutRead
|
||||
|
||||
-- execute the action
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile exe spath args env
|
||||
-- execute the action
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile exe spath args env
|
||||
|
||||
closeFd stdoutWrite
|
||||
|
||||
-- wait for the subprocess to finish
|
||||
e <- SPPB.getProcessStatus True True pid >>= \case
|
||||
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
|
||||
i -> pure $ toProcessError exe args i
|
||||
|
||||
-- make sure the logging thread stops
|
||||
case e of
|
||||
Left _ -> EX.throwTo tid (StopThread False)
|
||||
Right _ -> EX.throwTo tid (StopThread True)
|
||||
takeMVar done
|
||||
|
||||
closeFd stdoutRead
|
||||
pure e
|
||||
|
||||
-- Reads fdIn and logs the output in a continous scrolling area
|
||||
-- of 'size' terminal lines. Also writes to a log file.
|
||||
printToRegion fileFd fdIn size = do
|
||||
ref <- newIORef ([] :: [ByteString])
|
||||
displayConsoleRegions $ do
|
||||
rs <- sequence . replicate size . openConsoleRegion $ Linear
|
||||
flip finally (readTilEOF (lineAction ref rs) fdIn) -- make sure the last few lines don't get cut off
|
||||
$ handle
|
||||
(\(StopThread b) -> do
|
||||
when b (forM_ rs closeConsoleRegion)
|
||||
EX.throw (StopThread b)
|
||||
)
|
||||
$ do
|
||||
hideError eofErrorType $ readTilEOF (lineAction ref rs) fdIn
|
||||
-- wait for explicit stop from the parent to signal what cleanup to run
|
||||
forever (threadDelay 5000)
|
||||
|
||||
where
|
||||
-- action to perform line by line
|
||||
lineAction ref rs bs' = do
|
||||
modifyIORef' ref (swapRegs bs')
|
||||
regs <- readIORef ref
|
||||
forM (zip regs rs) $ \(bs, r) -> do
|
||||
setConsoleRegion r $ do
|
||||
w <- consoleWidth
|
||||
return
|
||||
. T.pack
|
||||
. color Blue
|
||||
. T.unpack
|
||||
. E.decodeUtf8With E.lenientDecode
|
||||
. trim w
|
||||
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
|
||||
$ bs
|
||||
SPIB.fdWrite fileFd (bs <> "\n")
|
||||
|
||||
|
||||
SPPB.getProcessStatus True True pid >>= \case
|
||||
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
|
||||
i -> pure $ toProcessError exe args i
|
||||
swapRegs bs regs | length regs < size = regs ++ [bs]
|
||||
| otherwise = tail regs ++ [bs]
|
||||
|
||||
-- trim output line to terminal width
|
||||
trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
|
||||
| otherwise = bs
|
||||
|
||||
-- read an entire line from the file descriptor (removes the newline char)
|
||||
readLine fd' = do
|
||||
bs <- SPIB.fdRead fd' 1
|
||||
if
|
||||
| bs == "\n" -> pure ""
|
||||
| bs == "" -> pure ""
|
||||
| otherwise -> fmap (bs <>) $ readLine fd'
|
||||
|
||||
readTilEOF action' fd' = do
|
||||
bs <- readLine fd'
|
||||
void $ action' bs
|
||||
readTilEOF action' fd'
|
||||
|
||||
|
||||
-- | Capture the stdout and stderr of the given action, which
|
||||
@@ -144,7 +242,7 @@ execLogged exe spath args lfile chdir env = do
|
||||
captureOutStreams :: IO a
|
||||
-- ^ the action to execute in a subprocess
|
||||
-> IO CapturedProcess
|
||||
captureOutStreams action =
|
||||
captureOutStreams action = do
|
||||
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
|
||||
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
@@ -159,27 +257,68 @@ captureOutStreams action =
|
||||
closeFd parentStderrRead
|
||||
|
||||
-- execute the action
|
||||
void $ action
|
||||
a <- action
|
||||
void $ evaluate a
|
||||
|
||||
-- close everything we don't need
|
||||
closeFd childStdoutWrite
|
||||
closeFd childStderrWrite
|
||||
|
||||
SPPB.getProcessStatus True True pid >>= \case
|
||||
-- start thread that writes the output
|
||||
refOut <- newIORef BS.empty
|
||||
refErr <- newIORef BS.empty
|
||||
done <- newEmptyMVar
|
||||
_ <-
|
||||
forkIO
|
||||
$ EX.handle (\(_ :: StopThread) -> pure ())
|
||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||
$ flip finally (putMVar done ())
|
||||
$ writeStds parentStdoutRead parentStderrRead refOut refErr
|
||||
|
||||
status <- SPPB.getProcessStatus True True pid
|
||||
takeMVar done
|
||||
|
||||
case status of
|
||||
-- readFd will take care of closing the fd
|
||||
Just (SPPB.Exited es) -> do
|
||||
stdout' <- L.toStrict <$> readFd parentStdoutRead
|
||||
stderr' <- L.toStrict <$> readFd parentStderrRead
|
||||
stdout' <- readIORef refOut
|
||||
stderr' <- readIORef refErr
|
||||
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
|
||||
writeStds pout perr rout rerr = do
|
||||
doneOut <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ hideError eofErrorType
|
||||
$ flip finally (putMVar doneOut ())
|
||||
$ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
|
||||
doneErr <- newEmptyMVar
|
||||
void
|
||||
$ forkIO
|
||||
$ hideError eofErrorType
|
||||
$ flip finally (putMVar doneErr ())
|
||||
$ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
|
||||
takeMVar doneOut
|
||||
takeMVar doneErr
|
||||
|
||||
readTilEOF ~action' fd' = do
|
||||
bs <- SPIB.fdRead fd' 512
|
||||
void $ action' bs
|
||||
readTilEOF action' fd'
|
||||
|
||||
|
||||
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
|
||||
actionWithPipes a =
|
||||
createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
|
||||
|
||||
cleanup :: [Fd] -> IO ()
|
||||
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -17,7 +17,6 @@ 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
|
||||
|
||||
@@ -1,4 +1,5 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
@@ -11,11 +12,12 @@ module GHCup.Utils.Version.QQ where
|
||||
import Data.Data
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import GHC.Base
|
||||
#endif
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
|
||||
import Language.Haskell.TH.Syntax ( Exp(..)
|
||||
, Lift
|
||||
import Language.Haskell.TH.Syntax ( Lift
|
||||
, dataToExpQ
|
||||
)
|
||||
import qualified Data.Text as T
|
||||
@@ -33,12 +35,15 @@ 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
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
deriving instance Lift (NonEmpty Word)
|
||||
instance Lift Text
|
||||
#endif
|
||||
|
||||
qq :: (Text -> Q Exp) -> QuasiQuoter
|
||||
qq quoteExp' = QuasiQuoter
|
||||
|
||||
@@ -6,6 +6,12 @@ module GHCup.Version where
|
||||
import GHCup.Utils.Version.QQ
|
||||
|
||||
import Data.Versions
|
||||
import URI.ByteString
|
||||
import URI.ByteString.QQ
|
||||
|
||||
-- | This reflects the API version of the JSON.
|
||||
ghcupURL :: URI
|
||||
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
|
||||
|
||||
ghcUpVer :: PVP
|
||||
ghcUpVer = [pver|0.1.0|]
|
||||
ghcUpVer = [pver|0.1.1|]
|
||||
|
||||
Reference in New Issue
Block a user