Compare commits

..

1 Commits

Author SHA1 Message Date
1810bb27a8 Experimental nice thing 2020-03-24 18:05:12 +01:00
33 changed files with 800 additions and 3754 deletions

View File

@@ -1,42 +0,0 @@
jobs:
include:
- os: osx
osx_image: xcode10.1
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.13-ghcup
addons:
homebrew:
packages:
- curl
- libffi
- libiconv
- make
- ncurses
- xz
- os: osx
osx_image: xcode11.3
language: generic
env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
addons:
homebrew:
packages:
- curl
- libffi
- libiconv
- make
- ncurses
- xz
script: ".travis/build.sh"
deploy:
provider: releases
api_key:
secure: GEQR+HIwMUql+tFU0LoKCCzG+IG1s5XVA4yp8xMFk0IPsNjHEMh6djYgNqsS6MnujzRulinZe69RyJMZHW3UbtVKWd1D5nsCKmAVfnU8VRbubaL55Bz7C2WI9UCYtKY0isVIQu3KkY+0a6LhdjSkbatO2hl9v0nFmN28q/RpEzsJTI4kyVhmCBflH4fL/QvXzfLuyOae7qsiZBVQXEhmySYktKifNMANSI1aU+kyZ3JgykqZogMK+g/fmcxxTe9MPYMsRQxae/xqdf87IQpmK8v9BRShvF0wq1gO8NY+/fEemAVIHi5CYhPgiLntUD/HFr6AT04LcHnaGryDn/PhkvHuDuZ4INYgBrdNMeGVTjT93N7OtXyh7c+AP3/51E8nM0SkSWCeP4P2fMMksdeOnKtPbhzlqgEM9tbRMILOj1LcjcqurU5ku+WEwZ7d1osTyNug7FVCO5Vb0q3NYnDF4UPXc/d5/2SB+SjJSMxRc52+BiKskHmOa96TXirL3eo6KVNaokQRKvbLw1fEjZvqYJuhPWBRDMalyYjc77poj4kzfVL9CYjtP7h6N5wFR7AtPsMz2n2fQf7J3N4+oqHK+83fOPGyy4FYPZojKNw+L2X/XYrfVscsY/1KbBjULgGIrdr4euYz+rRrTHixUYIvGclKOx+g3SHAOXFWhXlldvI=
file: $ARTIFACT
on:
repo: hasufell/ghcup-hs
tags: true
skip_cleanup: true
draft: true

View File

@@ -1,22 +0,0 @@
#/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}"

View File

@@ -1,42 +0,0 @@
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

View File

@@ -45,16 +45,16 @@ Common use cases are:
ghcup list
# install the recommended GHC version
ghcup install
ghcup install ghc
# install a specific GHC version
ghcup install 8.2.2
ghcup install ghc -v 8.2.2
# set the currently "active" GHC version
ghcup set 8.4.4
ghcup set -v 8.4.4
# install cabal-install
ghcup install-cabal
ghcup install cabal
# update ghcup itself
ghcup upgrade

43
TODO.md
View File

@@ -1,43 +0,0 @@
# TODOs and Remarks
## Now
* travis
* requirements
* for ghcup (bootstrap script)
* per tool
* mac build: xattr -cr .
* static binaries
* upgrade plan from old ghcup
* bootstrap-haskell with new ghcup
* add warning to ghcup script about new binary
* make sure smart-dl is not broken
* handle SIGINT better (remove dirs)
* review symlink handling (maybe fixed set of tools?)
## 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
* add support for RC/alpha/HEAD versions
## Cleanups
* avoid alternative for IO
* use plucky or oops instead of Excepts
## Questions
* fully static musl builds for linux?
* 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?

View File

@@ -832,64 +832,6 @@ ghc_883_32_musl = DownloadInfo
-----------------
--[ GHC 8.10.1 ]--
-----------------
ghc_8101_32_deb9 :: DownloadInfo
ghc_8101_32_deb9 = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-i386-deb9-linux.tar.xz|]
(Just [rel|ghc-8.10.1|])
"8b53eef2c827b5f634d72920a93c0c9dd66ea288691a2bfe28def45d3c686ee2"
ghc_8101_64_deb9 :: DownloadInfo
ghc_8101_64_deb9 = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-deb9-linux.tar.xz|]
(Just [rel|ghc-8.10.1|])
"d1cf7886f27af070f3b7dbe1975a78b43ef2d32b86362cbe953e79464fe70761"
ghc_8101_64_deb10 :: DownloadInfo
ghc_8101_64_deb10 = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-deb10-linux.tar.xz|]
(Just [rel|ghc-8.10.1|])
"c1e31d798b013699b3c0de4fda27fb4cda47f572df0e75e3bd598a3012060615"
ghc_8101_64_fedora :: DownloadInfo
ghc_8101_64_fedora = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-fedora27-linux.tar.xz|]
(Just [rel|ghc-8.10.1|])
"3c4cd72b4806045779739e8f5d1658e30e57123d88c2c8966422cdbcae448470"
ghc_8101_64_centos :: DownloadInfo
ghc_8101_64_centos = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-centos7-linux.tar.xz|]
(Just [rel|ghc-8.10.1|])
"0618b94854edc6be5302489df905e627820b71be6b66c950f5e3088fe92df0a1"
ghc_8101_64_darwin :: DownloadInfo
ghc_8101_64_darwin = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-apple-darwin.tar.xz|]
(Just [rel|ghc-8.10.1|])
"65b1ca361093de4804a7e40b3e68178e1ef720f84f743641ec8d95e56a45b3a8"
ghc_8101_64_alpine :: DownloadInfo
ghc_8101_64_alpine = DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-alpine3.10-linux-integer-simple.tar.xz|]
(Just [rel|ghc-8.10.1|])
"cb13b645d103e2fba2eb8dfcc4e5f2fbd9550c00c4df42f342b4210436dcb8a8"
---------------------
--[ Cabal-2.4.1.0 ]--
---------------------
@@ -953,32 +895,6 @@ cabal_3000_64_darwin = DownloadInfo
---------------------
--[ Cabal-3.2.0.0 ]--
---------------------
cabal_3200_32_linux :: DownloadInfo
cabal_3200_32_linux = DownloadInfo
[uri|https://downloads.haskell.org/cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-i386-unknown-linux.tar.xz|]
Nothing
"2b3ac28549916de5f3379241797eaf60e84b6c001f2abbe73d9fadbbaf768e93"
cabal_3200_64_linux :: DownloadInfo
cabal_3200_64_linux = DownloadInfo
[uri|https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-x86_64-unknown-linux.tar.xz|]
Nothing
"32d1f7cf1065c37cb0ef99a66adb405f409b9763f14c0926f5424ae408c738ac"
cabal_3200_64_darwin :: DownloadInfo
cabal_3200_64_darwin = DownloadInfo
[uri|https://downloads.haskell.org/cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-x86_64-apple-darwin17.7.0.tar.xz|]
Nothing
"9197c17d2ece0f934f5b33e323cfcaf486e4681952687bc3d249488ce3cbe0e9"
-------------
--[ GHCup ]--
-------------
@@ -986,30 +902,9 @@ cabal_3200_64_darwin = DownloadInfo
ghcup_010_64_linux :: DownloadInfo
ghcup_010_64_linux = DownloadInfo
[uri|https://www.haskell.org/ghcup/bin/0.1.0/x86_64-linux-ghcup-0.1.0|]
[uri|file:///home/maerwald/tmp/ghcup-exe|]
Nothing
"e2e124903193551df84679887a5741021f0d67df45442c9d3d2429e83b95aad1"
ghcup_010_64_freebsd :: DownloadInfo
ghcup_010_64_freebsd = DownloadInfo
[uri|https://www.haskell.org/ghcup/bin/0.1.0/x86_64-portbld-freebsd-ghcup-0.1.0|]
Nothing
"c6024c7f2849b6ed83cd683bb0a0e3d5b559aee3fba2ee78ada4f0c9804dbe36"
ghcup_010_64_darwin10_13 :: DownloadInfo
ghcup_010_64_darwin10_13 = DownloadInfo
[uri|https://www.haskell.org/ghcup/bin/0.1.0/x86_64-apple-darwin-10.13-ghcup-0.1.0|]
Nothing
"39b96cd984b6e8393bcb93eaeab2f4648e7ef4e4547afe623283774643eede58"
ghcup_010_64_darwin10_14 :: DownloadInfo
ghcup_010_64_darwin10_14 = DownloadInfo
[uri|https://www.haskell.org/ghcup/bin/0.1.0/x86_64-apple-darwin-10.14-ghcup-0.1.0|]
Nothing
"adfcf500f0414951685e53f72bbc9c1e3b2f41c06e562ed3f63fbd645bf61e54"
"558126339252788a3d44a3f910417277c7ab656f0796b68bdc58afe73296b8cd"
@@ -1525,7 +1420,7 @@ ghcupDownloads = M.fromList
)
, ( [vver|8.6.5|]
, VersionInfo
[]
[Recommended]
(Just $ DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-src.tar.xz|]
(Just [rel|ghc-8.6.5|])
@@ -1675,7 +1570,7 @@ ghcupDownloads = M.fromList
)
, ( [vver|8.8.3|]
, VersionInfo
[Recommended]
[Latest]
(Just $ DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.8.3/ghc-8.8.3-src.tar.xz|]
(Just [rel|ghc-8.8.3|])
@@ -1723,71 +1618,6 @@ ghcupDownloads = M.fromList
)
]
)
, ( [vver|8.10.1|]
, VersionInfo
[Latest]
(Just $ DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-src.tar.xz|]
(Just [rel|ghc-8.10.1|])
"4e3b07f83a266b3198310f19f71e371ebce97c769b14f0d688f4cbf2a2a1edf5"
)
$ M.fromList
[ ( A_64
, M.fromList
[ ( Linux UnknownLinux
, M.fromList [(Nothing, ghc_8101_64_fedora)]
)
, ( Linux Fedora
, M.fromList
[ (Nothing , ghc_8101_64_fedora)
, (Just [vers|27|], ghc_8101_64_fedora)
]
)
, ( Linux CentOS
, M.fromList
[ (Nothing , ghc_8101_64_centos)
, (Just [vers|7|], ghc_8101_64_centos)
]
)
, ( Linux AmazonLinux
, M.fromList [(Nothing, ghc_8101_64_centos)]
)
, ( Linux Ubuntu
, M.fromList
[ (Nothing , ghc_8101_64_fedora)
, (Just [vers|16.04|], ghc_8101_64_deb9)
, (Just [vers|18.04|], ghc_8101_64_deb9)
]
)
, (Linux Mint, M.fromList [(Nothing, ghc_8101_64_deb10)])
, ( Linux Debian
, M.fromList
[ (Nothing , ghc_8101_64_deb9)
, (Just [vers|9|] , ghc_8101_64_deb9)
, (Just [vers|10|], ghc_8101_64_deb10)
]
)
, (Darwin , M.fromList [(Nothing, ghc_8101_64_darwin)])
, (Linux Alpine, M.fromList [(Nothing, ghc_8101_64_alpine)])
]
)
, ( A_32
, M.fromList
[ ( Linux UnknownLinux
, M.fromList [(Nothing, ghc_8101_32_deb9)]
)
, (Linux Ubuntu, M.fromList [(Nothing, ghc_8101_32_deb9)])
, (Linux Mint , M.fromList [(Nothing, ghc_8101_32_deb9)])
, ( Linux Debian
, M.fromList
[ (Nothing , ghc_8101_32_deb9)
, (Just [vers|9|], ghc_8101_32_deb9)
]
)
]
)
]
)
]
)
, ( Cabal
@@ -1822,7 +1652,7 @@ ghcupDownloads = M.fromList
)
, ( [vver|3.0.0.0|]
, VersionInfo
[]
[Recommended, Latest]
(Just $ DownloadInfo
[uri|https://github.com/haskell/cabal/archive/cabal-install-v3.0.0.0.tar.gz|]
(Just [rel|cabal-cabal-install-v3.0.0.0/cabal-install|])
@@ -1846,51 +1676,15 @@ ghcupDownloads = M.fromList
)
]
)
, ( [vver|3.2.0.0|]
, VersionInfo
[Recommended, Latest]
(Just $ DownloadInfo
[uri|https://github.com/haskell/cabal/archive/cabal-install-v3.2.0.0.tar.gz|]
(Just [rel|cabal-cabal-install-v3.2.0.0/cabal-install|])
"77202358bdf0b481c09326268ce18880df14194c5aaa840f99510bdd1a124b75"
)
$ M.fromList
[ ( A_64
, M.fromList
[ ( Linux UnknownLinux
, M.fromList [(Nothing, cabal_3200_64_linux)]
)
, (Darwin, M.fromList [(Nothing, cabal_3200_64_darwin)])
]
)
, ( A_32
, M.fromList
[ ( Linux UnknownLinux
, M.fromList [(Nothing, cabal_3200_32_linux)]
)
]
)
]
)
]
)
, ( GHCup
, M.fromList
[ ( [vver|0.1.0|]
[ ( [vver|0.0.0|]
, VersionInfo [Recommended, Latest] Nothing $ M.fromList
[ ( A_64
, M.fromList
[ (Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])
, ( Darwin
, M.fromList
[ (Nothing , ghcup_010_64_darwin10_13)
, (Just [vers|10.13|], ghcup_010_64_darwin10_13)
, (Just [vers|10.14|], ghcup_010_64_darwin10_14)
, (Just [vers|10.15|], ghcup_010_64_darwin10_14)
]
)
, (FreeBSD, M.fromList [(Nothing, ghcup_010_64_freebsd)])
]
[(Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])]
)
]
)

View File

@@ -1,11 +0,0 @@
module GHCupInfo where
import GHCupDownloads
import ToolRequirements
import GHCup.Types
ghcupInfo :: GHCupInfo
ghcupInfo = GHCupInfo { _toolRequirements = toolRequirements
, _ghcupDownloads = ghcupDownloads
}

View File

@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -9,16 +8,13 @@
module Main where
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import GHCupInfo
import GHCupDownloads
import Data.Aeson ( eitherDecode )
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
@@ -136,7 +132,7 @@ main = do
GenJSON gopts -> do
let
bs = encodePretty' (defConfig { confIndent = Spaces 2 })
ghcupInfo
ghcupDownloads
case gopts of
GenJSONOpts { output = Nothing } -> L.hPutStr stdout bs
GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
@@ -160,7 +156,7 @@ main = do
where
valAndExit f contents = do
(GHCupInfo _ av) <- case eitherDecode contents of
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)

View File

@@ -1,94 +0,0 @@
{-# 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"
]
""
)
]
)
]
)
]
)
]

View File

@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -13,17 +12,13 @@ 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.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
@@ -32,6 +27,7 @@ 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
@@ -73,8 +69,7 @@ data Options = Options
}
data Command
= Install InstallOptions
| InstallCabal InstallOptions
= Install InstallCommand
| SetGHC SetGHCOptions
| List ListOptions
| Rm RmOptions
@@ -82,12 +77,14 @@ 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
, instPlatform :: Maybe PlatformRequest
@@ -113,10 +110,9 @@ data CompileCommand = CompileGHC CompileOptions
data CompileOptions = CompileOptions
{ targetVer :: Version
, bootstrapGhc :: Either Version (Path Abs)
, bootstrapVer :: Version
, jobs :: Maybe Int
, buildConfig :: Maybe (Path Abs)
, patchDir :: Maybe (Path Abs)
}
data UpgradeOpts = UpgradeInplace
@@ -130,11 +126,11 @@ opts =
Options
<$> switch
(short 'v' <> long "verbose" <> help
"Enable verbosity"
"Whether to enable verbosity (default: False)"
)
<*> switch
(short 'c' <> long "cache" <> help
"Cache downloads in ~/.ghcup/cache"
"Whether to cache downloads (default: False)"
)
<*> (optional
(option
@@ -149,7 +145,7 @@ opts =
)
<*> switch
(short 'n' <> long "no-verify" <> help
"Skip tarball checksum verification"
"Skip tarball checksum verification (default: False)"
)
<*> com
where
@@ -162,29 +158,11 @@ com =
subparser
( command
"install"
((info ((Install <$> installOpts) <**> helper)
(progDesc "Install or update GHC")
)
( Install
<$> (info (installP <**> helper)
(progDesc "Install or update GHC/cabal")
)
)
<> 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
@@ -195,7 +173,10 @@ com =
<> command
"upgrade"
( Upgrade
<$> (info (upgradeOptsP <**> helper) (progDesc "Upgrade ghcup"))
<$> (info
(upgradeOptsP <**> helper)
(progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
)
)
<> command
"compile"
@@ -206,6 +187,25 @@ com =
)
<> 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"
@@ -215,22 +215,32 @@ 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 =
(flip InstallOptions)
<$> (optional
InstallOptions
<$> optional toolVersionParser
<*> (optional
(option
(eitherReader platformParser)
( short 'p'
@@ -241,11 +251,10 @@ installOpts =
)
)
)
<*> optional toolVersionArgument
setGHCOpts :: Parser SetGHCOptions
setGHCOpts = SetGHCOptions <$> optional toolVersionArgument
setGHCOpts = SetGHCOptions <$> optional toolVersionParser
listOpts :: Parser ListOptions
listOpts =
@@ -269,7 +278,7 @@ listOpts =
)
rmOpts :: Parser RmOptions
rmOpts = RmOptions <$> versionArgument
rmOpts = RmOptions <$> versionParser
compileP :: Parser CompileCommand
@@ -303,16 +312,12 @@ compileOpts =
)
<*> (option
(eitherReader
(\x ->
(bimap (const "Not a valid version") Left . version . T.pack $ x)
<|> (bimap show Right . parseAbs . E.encodeUtf8 . T.pack $ x)
)
(bimap (const "Not a valid version") id . version . T.pack)
)
( short 'b'
<> long "bootstrap-ghc"
<> metavar "BOOTSTRAP_GHC"
<> help
"The GHC version (or full path) to bootstrap with (must be installed)"
<> long "bootstrap-version"
<> metavar "BOOTSTRAP_VERSION"
<> help "The GHC version to bootstrap with (must be installed)"
)
)
<*> optional
@@ -335,19 +340,13 @@ compileOpts =
"Absolute path to build config file"
)
)
<*> 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)"
)
)
versionParser :: Parser Version
versionParser = option
(eitherReader (bimap (const "Not a valid version") id . version . T.pack))
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
)
toolVersionParser :: Parser ToolVersion
@@ -357,44 +356,16 @@ toolVersionParser = verP <|> toolP
toolP =
ToolTag
<$> (option
(eitherReader tagEither)
(eitherReader
(\s' -> case fmap toLower s' of
"recommended" -> Right Recommended
"latest" -> Right Latest
other -> Left ([i|Unknown tag #{other}|])
)
)
(short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
)
-- | 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
@@ -589,15 +560,10 @@ main = do
@'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, DownloadFailed
]
let runCompileCabal =
@@ -605,15 +571,11 @@ main = do
. flip runReaderT settings
. runResourceT
. runE
@'[ BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
@'[ UnknownArchive
, NoDownload
, PatchFailed
, UnknownArchive
, DigestError
, BuildFailed
, DownloadFailed
]
let runUpgrade =
@@ -631,7 +593,7 @@ main = do
, DownloadFailed
]
(GHCupInfo treq dls) <-
dls <-
( runLogger
. flip runReaderT settings
. runE @'[JSONError , DownloadFailed]
@@ -647,7 +609,7 @@ main = do
runLogger $ checkForUpdates dls
case optCommand of
Install (InstallOptions {..}) ->
Install (InstallGHC InstallOptions {..}) ->
void
$ (runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
@@ -670,7 +632,7 @@ 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
InstallCabal (InstallOptions {..}) ->
Install (InstallCabal InstallOptions {..}) ->
void
$ (runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
@@ -734,7 +696,7 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues
void
$ (runCompileGHC $ do
liftE
$ compileGHC dls targetVer bootstrapGhc jobs buildConfig patchDir
$ compileGHC dls targetVer bootstrapVer jobs buildConfig
)
>>= \case
VRight _ ->
@@ -755,7 +717,7 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues
Compile (CompileCabal CompileOptions {..}) ->
void
$ (runCompileCabal $ do
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir
liftE $ compileCabal dls targetVer bootstrapVer jobs
)
>>= \case
VRight _ ->
@@ -795,21 +757,6 @@ 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 ()

View File

@@ -1,190 +0,0 @@
#!/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 "${_arch}" in
x86_64|amd64)
;;
i*86)
die "i386 currently not supported!"
;;
*) die "Unknown architecture: ${_arch}"
;;
esac
case "${_plat}" in
"linux"|"Linux")
_url=https://www.haskell.org/ghcup/bin/x86_64-linux-ghcup
;;
"FreeBSD"|"freebsd")
_url=https://www.haskell.org/ghcup/bin/x86_64-portbld-freebsd-ghcup
;;
"Darwin"|"darwin")
case "$(sw_vers -productVersion || echo "none")" in
10.15.*) _url=https://www.haskell.org/ghcup/bin/x86_64-apple-darwin-10.14-ghcup ;;
10.14.*) _url=https://www.haskell.org/ghcup/bin/x86_64-apple-darwin-10.14-ghcup ;;
10.13.*) _url=https://www.haskell.org/ghcup/bin/x86_64-apple-darwin-10.13-ghcup ;;
*) _url=https://www.haskell.org/ghcup/bin/x86_64-apple-darwin-10.13-ghcup ;;
esac
;;
*) 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

View File

@@ -1,5 +1,7 @@
packages: ./ghcup.cabal
with-compiler: ghc-8.6.5
optimization: 2
package streamly
@@ -13,4 +15,4 @@ package tar-bytestring
constraints: http-io-streams -brotli
allow-newer: base
index-state: 2020-03-09T18:53:34Z

258
cabal.project.freeze Normal file
View File

@@ -0,0 +1,258 @@
constraints: any.Cabal ==2.4.0.1,
any.Glob ==0.10.0,
any.HsOpenSSL ==0.11.4.17,
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -old-locale,
any.IfElse ==0.85,
any.Only ==0.1,
any.QuickCheck ==2.13.2,
QuickCheck +templatehaskell,
any.StateVar ==1.2,
any.abstract-deque ==0.3,
abstract-deque -usecas,
any.abstract-par ==0.3.3,
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-compat-batteries ==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.binary-orphans ==1.0.1,
any.blaze-builder ==0.4.1.0,
any.bytestring ==0.10.8.2,
any.bytestring-builder ==0.10.8.2.0,
bytestring-builder +bytestring_has_builder,
any.bytestring-handle ==0.1.0.6,
any.bzlib ==0.5.0.5,
any.cabal-doctest ==1.0.8,
any.case-insensitive ==1.2.1.0,
any.cassava ==0.5.2.0,
cassava -bytestring--lt-0_10_4,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.clock ==0.8,
clock -llvm,
any.cmdargs ==0.10.20,
cmdargs +quotation -testprog,
any.code-page ==0.2,
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.criterion ==1.5.6.2,
criterion -embed-data-files -fast,
any.criterion-measurement ==0.1.2.0,
criterion-measurement -fast,
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.dense-linear-algebra ==0.1.0.0,
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.js-flot ==0.8.3,
any.js-jquery ==3.3.1,
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.microstache ==1.0.1.1,
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.monad-par ==0.3.5,
monad-par -chaselev -newgeneric,
any.monad-par-extras ==0.3.3,
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.parallel ==3.2.2.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.regex-base ==0.94.0.0,
any.regex-posix ==0.96.0.0,
regex-posix -_regex-posix-clib,
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.statistics ==0.15.2.0,
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.1,
any.tasty ==1.2.3,
tasty +clock,
any.tasty-quickcheck ==0.10.1.1,
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-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.unbounded-delays ==0.1.1.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-binary-instances ==0.2.5.1,
any.vector-builder ==0.3.8,
any.vector-th-unbox ==0.2.1.7,
any.versions ==3.5.3,
any.wcwidth ==0.0.2,
wcwidth -cli +split-base,
any.word8 ==0.1.3,
any.zlib ==0.6.2.1,
zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5

View File

@@ -1,14 +0,0 @@
#!/bin/sh
set -ex
cd /app
cabal v2-update
cabal v2-install \
--install-method=copy \
--overwrite-policy=always \
--installdir="/bin" \
--ghc-options='-optl-static'

0
foo
View File

File diff suppressed because it is too large Load Diff

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.0
version: 0.1.0.0
synopsis: ghc toolchain installer as an exe/library
description:
A rewrite of the shell script ghcup, for providing
@@ -21,13 +21,8 @@ source-repository head
type: git
location: https://github.com/hasufell/ghcup-hs
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
build-depends: HsOpenSSL >=0.11
common aeson
build-depends: aeson >=1.4
@@ -47,17 +42,14 @@ common attoparsec
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 bzlib
build-depends: bzlib >=0.5.0.5
common case-insensitive
build-depends: case-insensitive >=1.2.1.0
@@ -68,9 +60,6 @@ common concurrent-output
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
@@ -80,6 +69,9 @@ common haskus-utils-types
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
@@ -226,26 +218,28 @@ library
import:
config
, base
, base16-bytestring
, HsOpenSSL
, aeson
, ascii-string
, async
, attoparsec
, binary
, bytestring
, bz2
, bzlib
, case-insensitive
, concurrent-output
, containers
, cryptohash-sha256
, 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
@@ -265,6 +259,7 @@ library
, string-interpolate
, tar-bytestring
, template-haskell
, terminal-progress-bar
, text
, time
, transformers
@@ -277,13 +272,13 @@ library
, word8
, zlib
-- deps
-- cabal-fmt: expand lib
exposed-modules:
GHCup
GHCup.Download
GHCup.Download.Utils
GHCup.Errors
GHCup.Platform
GHCup.Requirements
GHCup.Types
GHCup.Types.JSON
GHCup.Types.Optics
@@ -301,16 +296,6 @@ library
-- other-extensions:
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
@@ -318,20 +303,20 @@ executable ghcup
, bytestring
, containers
, haskus-utils-variant
, hpath
, hpath-io
, megaparsec
, monad-logger
, megaparsec
, mtl
, optparse-applicative
, text
, versions
, hpath
, hpath-io
, pretty-terminal
, resourcet
, string-interpolate
, table-layout
, text
, uri-bytestring
, utf8-string
, versions
--
main-is: Main.hs
@@ -350,29 +335,27 @@ executable ghcup-gen
, aeson-pretty
, bytestring
, containers
, safe-exceptions
, haskus-utils-variant
, hpath
, monad-logger
, mtl
, optics
, optparse-applicative
, text
, versions
, hpath
, 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:

View File

@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -29,11 +28,10 @@ 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 )
@@ -53,6 +51,8 @@ import Prelude hiding ( abs
)
import System.IO.Error
import System.Posix.FilePath ( getSearchPath )
import System.Posix.RawFilePath.Directory.Errors
( hideError )
import qualified Data.ByteString as B
import qualified Data.Map.Strict as Map
@@ -96,16 +96,14 @@ 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 <- lE $ getDownloadInfo GHC ver pfreq bDls
dlinfo <- liftE $ getDownloadInfo bDls GHC ver mpfReq
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- prepare paths
ghcdir <- liftIO $ ghcupGHCDir ver
@@ -172,16 +170,14 @@ 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 <- lE $ getDownloadInfo Cabal ver pfreq bDls
dlinfo <- liftE $ getDownloadInfo bDls Cabal ver mpfReq
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- prepare paths
bindir <- liftIO ghcupBinDir
@@ -439,29 +435,23 @@ compileGHC :: ( MonadMask m
, MonadFail m
)
=> GHCupDownloads
-> Version -- ^ version to install
-> Either Version (Path Abs) -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs
-> Maybe (Path Abs) -- ^ build config
-> Maybe (Path Abs)
-> Version -- ^ version to install
-> Version -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs
-> Maybe (Path Abs) -- ^ build config
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
]
m
()
compileGHC dls tver bstrap jobs mbuildConfig patchdir = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
compileGHC dls tver bver jobs mbuildConfig = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
whenM (liftIO $ toolAlreadyInstalled GHC tver)
(throwE $ AlreadyInstalled GHC tver)
@@ -472,12 +462,8 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
(PlatformRequest {..}) <- liftE $ platformRequest
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
bghc <- parseRel ("ghc-" <> verToBS bver)
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
ghcdir <- liftIO $ ghcupGHCDir tver
@@ -509,32 +495,23 @@ HADDOCK_DOCS = YES
GhcWithLlvmCodeGen = YES|]
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
=> Either (Path Rel) (Path Abs)
=> Path Rel
-> Path Abs
-> Path Abs
-> Excepts
'[ FileDoesNotExistError
, PatchFailed
, ProcessError
, NotFoundInPATH
]
'[NoDownload , FileDoesNotExistError , ProcessError]
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
bghcPath <- case bghc of
Right ghc' -> pure ghc'
Left bver -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
(liftIO $ searchPath spaths bver) !? NotFoundInPATH bver
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
bghcPath <- (liftIO $ searchPath spaths bghc) !? NoDownload
lEM $ liftIO $ execLogged
"./configure"
False
@@ -546,9 +523,7 @@ GhcWithLlvmCodeGen = YES|]
lEM $ liftIO $ execLogged
"./configure"
False
[ "--prefix=" <> toFilePath ghcdir
, "--with-ghc=" <> either toFilePath toFilePath bghc
]
["--prefix=" <> toFilePath ghcdir, "--with-ghc=" <> toFilePath bghc]
[rel|ghc-conf|]
(Just workdir)
(Just newEnv)
@@ -561,7 +536,9 @@ GhcWithLlvmCodeGen = YES|]
Nothing ->
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
lift $ $(logInfo) [i|Building (this may take a while)...|]
lift
$ $(logInfo)
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/ghc-make.log' to see the progress.|]
lEM $ liftIO $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
(Just workdir)
@@ -583,24 +560,19 @@ compileCabal :: ( MonadReader Settings m
)
=> GHCupDownloads
-> Version -- ^ version to install
-> Either Version (Path Abs) -- ^ version to bootstrap with
-> Version -- ^ GHC version to build with
-> Maybe Int
-> Maybe (Path Abs)
-> Excepts
'[ BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, PatchFailed
, UnknownArchive
]
m
()
compileCabal dls tver bghc jobs patchdir = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
compileCabal dls tver bver jobs = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bver}|]
-- download source tarball
dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
@@ -609,8 +581,6 @@ compileCabal dls tver bghc jobs patchdir = 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
@@ -622,33 +592,22 @@ compileCabal dls tver bghc jobs patchdir = do
pure ()
where
compile :: (MonadThrow m, MonadLogger m, MonadIO m)
compile :: (MonadLogger m, MonadIO m)
=> Path Abs
-> Excepts '[ProcessError , PatchFailed] m ()
-> Excepts '[ProcessError] m ()
compile workdir = do
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')]
lift
$ $(logInfo)
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/cabal-bootstrap.log' to see the progress.|]
let v' = verToBS bver
cabal_bin <- liftIO $ ghcupBinDir
newEnv <- lift
$ addToCurrentEnv (("PREFIX", toFilePath cabal_bin) : ghcEnv)
lift $ $(logDebug) [i|Environment: #{newEnv}|]
newEnv <- lift $ addToCurrentEnv
[ ("GHC" , "ghc-" <> v')
, ("GHC_PKG", "ghc-pkg-" <> v')
, ("GHC_VER", v')
, ("PREFIX" , toFilePath cabal_bin)
]
lEM $ liftIO $ execLogged "./bootstrap.sh"
False
@@ -689,23 +648,17 @@ upgradeGHCup :: ( MonadMask m
upgradeGHCup dls mtarget = do
lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ getLatest dls GHCup
pfreq <- liftE platformRequest
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
tmp <- lift withGHCupTmpDir
dli <- liftE $ getDownloadInfo dls GHCup latestVer Nothing
tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|]
p <- liftE $ download dli tmp (Just fn)
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 -> do
liftIO $ hideError NoSuchThing $ deleteFile fullDest
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
fullDest
Overwrite
Just fullDest -> liftIO $ copyFile p fullDest Overwrite
pure latestVer

View File

@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -11,69 +10,75 @@
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.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 )
#endif
import Data.IORef
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 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 Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString.Base16 as B16
import qualified Data.Binary.Builder as B
import qualified Data.ByteString as BS
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,7 +98,7 @@ getDownloads :: ( FromJSONKey Tool
, MonadFail m
)
=> URLSource
-> Excepts '[JSONError , DownloadFailed] m GHCupInfo
-> Excepts '[JSONError , DownloadFailed] m GHCupDownloads
getDownloads urlSource = do
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
case urlSource of
@@ -125,7 +130,6 @@ getDownloads urlSource = do
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
, ProcessError
]
m1
L.ByteString
@@ -154,7 +158,7 @@ getDownloads urlSource = do
pure bs
else liftIO $ readFile json_file
Nothing -> do
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
liftIO $ deleteFile json_file
liftE $ downloadBS uri'
else -- access in less than 5 minutes, re-use file
@@ -167,14 +171,11 @@ getDownloads urlSource = do
liftIO $ writeFileWithModTime modTime json_file bs
pure bs
Nothing -> do
lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
lift $ $(logWarn) [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
@@ -186,6 +187,7 @@ getDownloads urlSource = do
)
pure $ parseModifiedHeader headers
parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
parseModifiedHeader headers =
(M.lookup (CI.mk "Last-Modified") headers) >>= \h -> parseTimeM
@@ -194,8 +196,6 @@ getDownloads urlSource = do
"%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,13 +203,43 @@ getDownloads urlSource = do
setModificationTimeHiRes path mod_time
getDownloadInfo :: Tool
getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
=> GHCupDownloads
-> Tool
-> Version
-> Maybe PlatformRequest
-> Excepts
'[ DistroNotFound
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload
]
m
DownloadInfo
getDownloadInfo bDls t v mpfReq = do
(PlatformRequest arch' plat ver) <- case mpfReq of
Just x -> pure x
Nothing -> do
(PlatformResult rp rv) <- liftE getPlatform
ar <- lE getArchitecture
pure $ PlatformRequest ar rp rv
lE $ getDownloadInfo' t v arch' plat ver bDls
getDownloadInfo' :: Tool
-> Version
-- ^ tool version
-> PlatformRequest
-> GHCupDownloads
-> Either NoDownload DownloadInfo
getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
-> Architecture
-- ^ user arch
-> Platform
-- ^ user platform
-> Maybe Versioning
-- ^ optional version of the platform
-> GHCupDownloads
-> Either NoDownload DownloadInfo
getDownloadInfo' t v a p mv dls = maybe
(Left NoDownload)
Right
(with_distro <|> without_distro_ver <|> without_distro)
@@ -259,25 +289,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 onException
(liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
$ flip finally (liftIO $ closeFd fd)
$ catchAllE
(\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
)
$ downloadInternal True https host fullPath port stepper
liftE $ checkDigest dli destFile
pure destFile
@@ -326,8 +356,6 @@ downloadCached dli mfn = do
------------------
-- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m)
=> URI
@@ -338,7 +366,6 @@ downloadBS :: (MonadCatch m, MonadIO m)
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
, ProcessError
]
m
L.ByteString
@@ -356,19 +383,221 @@ 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'
#endif
-- | 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 "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
]
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)
-- | 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
checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m)
@@ -381,7 +610,6 @@ checkDigest dli file = do
let p' = toFilePath file
lift $ $(logInfo) [i|verifying digest of: #{p'}|]
c <- liftIO $ readFile file
let cDigest = E.decodeUtf8 . B16.encode . SHA256.hashlazy $ c
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
eDigest = view dlHash dli
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)

View File

@@ -1,254 +0,0 @@
{-# 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)

View File

@@ -1,64 +0,0 @@
{-# 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

View File

@@ -63,10 +63,6 @@ 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
@@ -92,13 +88,6 @@ 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
-------------------------

View File

@@ -22,6 +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
@@ -46,21 +47,6 @@ import qualified Data.Text.Encoding as E
--------------------------
-- | 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
@@ -79,30 +65,16 @@ getPlatform = do
"linux" -> do
(distro, ver) <- liftE getLinuxDistro
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
"darwin" -> do
ver <-
( either (const Nothing) Just
. versioning
. getMajorVersion
. E.decodeUtf8
)
<$> getDarwinVersion
pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
-- TODO: these are not verified
"darwin" ->
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
"freebsd" -> do
ver <-
(either (const Nothing) Just . versioning . E.decodeUtf8)
<$> getFreeBSDVersion
ver <- getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
pure pfr
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
where getFreeBSDVersion = pure Nothing
getLinuxDistro :: (MonadCatch m, MonadIO m)

View File

@@ -1,46 +0,0 @@
{-# 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

View File

@@ -12,39 +12,6 @@ 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 ]--
@@ -132,7 +99,7 @@ data DownloadInfo = DownloadInfo
-- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL
| OwnSource URI
| OwnSpec GHCupInfo
| OwnSpec GHCupDownloads
deriving Show

View File

@@ -18,6 +18,7 @@ import GHCup.Utils.Prelude
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
@@ -39,8 +40,6 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
instance ToJSON URI where
@@ -71,11 +70,11 @@ instance FromJSONKey Versioning where
instance ToJSONKey (Maybe Versioning) where
toJSONKey = toJSONKeyText $ \case
Just x -> prettyV x
Nothing -> T.pack "unknown_versioning"
Nothing -> T.pack "unknown_version"
instance FromJSONKey (Maybe Versioning) where
fromJSONKey = FromJSONKeyTextParser $ \t ->
if t == T.pack "unknown_versioning" then pure Nothing else pure $ just t
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
where
just t = case versioning t of
Right x -> pure x
@@ -114,19 +113,6 @@ 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

View File

@@ -19,7 +19,6 @@ makeLenses ''DownloadInfo
makeLenses ''Tag
makeLenses ''VersionInfo
makeLenses ''GHCupInfo
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
uriSchemeL' = lensVL uriSchemeL

View File

@@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -23,11 +22,10 @@ import GHCup.Utils.Prelude
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
@@ -297,7 +295,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.:
@@ -338,33 +336,3 @@ make args workdir = do
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 ()

View File

@@ -6,9 +6,10 @@ module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Concurrent
import Control.Exception ( evaluate )
import Control.Concurrent.MVar
import Control.Exception.Safe
import Control.Monad
import Data.ByteString ( ByteString )
@@ -18,6 +19,8 @@ import Data.Foldable
import Data.Functor
import Data.IORef
import Data.Maybe
import Data.Word8
import GHC.Conc hiding ( threadWaitRead )
import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.IO.Exception
@@ -27,6 +30,7 @@ import Optics
import Streamly
import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import System.Console.Concurrent
import System.Console.Pretty
import System.Console.Regions
import System.IO
@@ -44,7 +48,6 @@ 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
@@ -59,7 +62,6 @@ import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
-- | Bool signals whether the regions should be cleaned.
data StopThread = StopThread Bool
deriving Show
@@ -147,8 +149,8 @@ execLogged exe spath args lfile chdir env = do
done <- newEmptyMVar
tid <-
forkIO
$ EX.handle (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ())
$ EX.handle (\(e :: StopThread) -> pure ())
$ EX.handle (\(e :: IOException) -> pure ())
$ flip finally (putMVar done ())
$ printToRegion fd stdoutRead 6
@@ -185,36 +187,32 @@ execLogged exe spath args lfile chdir env = 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)
EX.handle
(\(StopThread b) -> do
when b (forM_ rs closeConsoleRegion)
EX.throw (StopThread b)
)
$ readForever
(\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.decodeUtf8
. trim w
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
$ bs
SPIB.fdWrite fileFd (bs <> "\n")
)
$ do
hideError eofErrorType $ readTilEOF (lineAction ref rs) fdIn
-- wait for explicit stop from the parent to signal what cleanup to run
forever (threadDelay 5000)
fdIn
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")
swapRegs bs regs | length regs < size = regs ++ [bs]
| otherwise = tail regs ++ [bs]
@@ -224,16 +222,18 @@ execLogged exe spath args lfile chdir env = do
-- read an entire line from the file descriptor (removes the newline char)
readLine fd' = do
threadWaitRead fd'
bs <- SPIB.fdRead fd' 1
if
| bs == "\n" -> pure ""
| bs == "" -> pure ""
| otherwise -> fmap (bs <>) $ readLine fd'
readTilEOF action' fd' = do
readForever action' fd' = do
bs <- readLine fd'
void $ action' bs
readTilEOF action' fd'
if not $ BS.null bs
then action' bs >> readForever action' fd'
else readForever action' fd'
-- | Capture the stdout and stderr of the given action, which
@@ -242,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 = do
captureOutStreams action =
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
pid <- SPPB.forkProcess $ do
@@ -257,61 +257,23 @@ captureOutStreams action = do
closeFd parentStderrRead
-- execute the action
a <- action
void $ evaluate a
void $ action
-- close everything we don't need
closeFd childStdoutWrite
closeFd childStderrWrite
-- 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
SPPB.getProcessStatus True True pid >>= \case
-- readFd will take care of closing the fd
Just (SPPB.Exited es) -> do
stdout' <- readIORef refOut
stderr' <- readIORef refErr
stdout' <- L.toStrict <$> readFd parentStdoutRead
stderr' <- L.toStrict <$> readFd parentStderrRead
pure $ CapturedProcess { _exitCode = es
, _stdOut = stdout'
, _stdErr = stderr'
}
_ -> throwIO $ userError $ ("No such PID " ++ show pid)
where
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 =

View File

@@ -17,6 +17,7 @@ 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

View File

@@ -1,5 +1,4 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -12,12 +11,11 @@ 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 ( Lift
import Language.Haskell.TH.Syntax ( Exp(..)
, Lift
, dataToExpQ
)
import qualified Data.Text as T
@@ -35,15 +33,12 @@ 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

View File

@@ -6,12 +6,6 @@ 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.0.0|]

39
stack.yaml Normal file
View File

@@ -0,0 +1,39 @@
resolver: lts-14.27
packages:
- .
extra-deps:
- IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2
- ascii-string-1.0.1.3
- brotli-0.0.0.0@sha256:448061ceabdcaa752bbaf208f255bbb7e90bbcf8ea8a913d26ffa7887636823b
- brotli-streams-0.0.0.0@sha256:c75a1d5d33420cbc9399c315e9b50a1976a5370f4fa8a40c71e11d011c2fedd6
- case-insensitive-1.2.1.0
- data-default-instances-base-0.1.0.1@sha256:985a13d7103e45a65f06f277b735ef025636014f0d29dd6de998bc7628e09be9
- fusion-plugin-types-0.1.0@sha256:0f11bbc445ab8ae3dbbb3d5d2ea198bdb1ac020518b7f4f7579035dc89182438
- generics-sop-0.5.0.0
- haskus-utils-data-1.2@sha256:48f62aa23d84b94edd0338379d3b3d74a34d3c2dbabf8c448a774a89ca70ea5d
- haskus-utils-types-1.5
- haskus-utils-variant-3.0
- hpath-0.11.0
- hpath-directory-0.13.2
- hpath-filepath-0.10.4
- hpath-io-0.13.1
- hpath-posix-0.13.1
- http-io-streams-0.1.2.0
- indexed-profunctors-0.1@sha256:ddf618d0d4c58319c1e735e746bc69a1021f13b6f475dc9614b80af03432e6d4
- language-bash-0.9.0
- optics-0.2
- optics-core-0.2@sha256:cfdf39871553769b59fcc54863a3521d262ea25d8d05d0f41ab87296c560cfa6
- optics-extra-0.2@sha256:211ce1dfd1b3ffd95c1158d8c8beb53cbd17c4d477169e226b1831607f6789eb
- optics-th-0.2@sha256:b4f6c5a3f134c697837190ed6da969dd284aefe79e43c3ef793093b607bb83b9
- optics-vl-0.2
- optparse-applicative-0.15.1.0
- pretty-terminal-0.1.0.0
- sop-core-0.5.0.0@sha256:8734ab38b8c84837094eec657da0b58942e481e20166131f34cf6c7fe9787b07
- streamly-0.7.1
- streamly-bytestring-0.1.2
- streamly-posix-0.1.0.0
- strict-base-0.4.0.0
- string-interpolate-0.2.0.0
- table-layout-0.8.0.5
- tar-bytestring-0.6.3.0
- time-1.9.3