Allow to build with curl (cli) instead of http-io-streams

This allows to avoid linking against OpenSSL on mac.

Dockerfile

@@ -0,0 +1,45 @@
+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 \
+	libbz2 \
+	bzip2-dev \
+	bzip2-static \
+	zlib \
+	zlib-dev \
+	zlib-static \
+	gmp \
+	gmp-dev \
+	openssl-dev \
+	openssl-libs-static \
+	xz \
+	xz-dev
+
+
+
+COPY . /app
+
+WORKDIR /app
+
+RUN chmod +x /app/docker/build.sh
+

TODO.md

@@ -0,0 +1,43 @@
+# 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?

app/ghcup-gen/GHCupDownloads.hs

@@ -832,6 +832,64 @@ 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 ]--
     ---------------------
@@ -895,13 +953,39 @@ 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 ]--
     -------------
 
 
-ghcup_010_64_linux :: DownloadInfo
+ghcup_001_64_linux :: DownloadInfo
-ghcup_010_64_linux = DownloadInfo
+ghcup_001_64_linux = DownloadInfo
   [uri|file:///home/maerwald/tmp/ghcup-exe|]
   Nothing
   "558126339252788a3d44a3f910417277c7ab656f0796b68bdc58afe73296b8cd"
@@ -1420,7 +1504,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|])
@@ -1570,7 +1654,7 @@ ghcupDownloads = M.fromList
         )
       , ( [vver|8.8.3|]
         , VersionInfo
-            [Latest]
+            [Recommended]
             (Just $ DownloadInfo
               [uri|https://downloads.haskell.org/~ghc/8.8.3/ghc-8.8.3-src.tar.xz|]
               (Just [rel|ghc-8.8.3|])
@@ -1618,6 +1702,71 @@ 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
@@ -1652,7 +1801,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|])
@@ -1676,15 +1825,41 @@ 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.1|]
         , VersionInfo [Recommended, Latest] Nothing $ M.fromList
           [ ( A_64
             , M.fromList
-              [(Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])]
+              [(Linux UnknownLinux, M.fromList [(Nothing, ghcup_001_64_linux)])]
             )
           ]
         )

app/ghcup/Main.hs

@@ -18,7 +18,6 @@ import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
 import           GHCup.Version
 
-import           Control.Monad.Fail             ( MonadFail )
 import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
@@ -27,7 +26,6 @@ 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
@@ -110,9 +108,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
@@ -312,12 +311,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"
+          <> long "bootstrap-ghc"
-          <> metavar "BOOTSTRAP_VERSION"
+          <> metavar "BOOTSTRAP_GHC"
-          <> help "The GHC version to bootstrap with (must be installed)"
+          <> help
+               "The GHC version (or full path) to bootstrap with (must be installed)"
           )
         )
     <*> optional
@@ -340,6 +343,19 @@ 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
@@ -562,6 +578,7 @@ main = do
                       , DigestError
                       , GHCupSetError
                       , NoDownload
+                      , PatchFailed
                       , UnknownArchive
                       , DownloadFailed
                       ]
@@ -575,6 +592,7 @@ main = do
                       , NoDownload
                       , DigestError
                       , BuildFailed
+                      , PatchFailed
                       , DownloadFailed
                       ]
 
@@ -696,7 +714,7 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues
               void
                 $   (runCompileGHC $ do
                       liftE
-                        $ compileGHC dls targetVer bootstrapVer jobs buildConfig
+                        $ compileGHC dls targetVer bootstrapGhc jobs buildConfig patchDir
                     )
                 >>= \case
                       VRight _ ->
@@ -717,7 +735,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 bootstrapVer jobs
+                      liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir
                     )
                 >>= \case
                       VRight _ ->

cabal.project

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

cabal.project.freeze

@@ -1,34 +1,33 @@
-constraints: any.Cabal ==2.4.0.1,
+constraints: any.Cabal ==3.0.1.0,
-             any.Glob ==0.10.0,
+             any.HsOpenSSL ==0.11.4.18,
-             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.14,
-             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.7.1,
-             any.aeson ==1.4.6.0,
              aeson -bytestring-builder -cffi -developer -fast,
              any.aeson-pretty ==0.8.8,
              aeson-pretty -lib-only,
+             any.alex ==3.2.5,
+             alex +small_base,
              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.array ==0.5.4.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,
+             any.attoparsec ==0.13.2.4,
              attoparsec -developer,
              any.auto-update ==0.1.6,
-             any.base ==4.12.0.0,
+             any.base ==4.13.0.0,
              any.base-compat ==0.11.1,
              any.base-compat-batteries ==0.11.1,
              any.base-orphans ==0.8.2,
@@ -37,59 +36,53 @@ constraints: any.Cabal ==2.4.0.1,
              any.base64-bytestring ==1.0.0.3,
              any.bifunctors ==5.5.7,
              bifunctors +semigroups +tagged,
-             any.binary ==0.8.6.0,
+             any.binary ==0.8.7.0,
-             any.binary-orphans ==1.0.1,
              any.blaze-builder ==0.4.1.0,
-             any.bytestring ==0.10.8.2,
+             any.bytestring ==0.10.10.0,
              any.bytestring-builder ==0.10.8.2.0,
              bytestring-builder +bytestring_has_builder,
-             any.bytestring-handle ==0.1.0.6,
+             any.bz2 ==1.0.0.2,
-             any.bzlib ==0.5.0.5,
+             bz2 -cross +with-bzlib,
+             any.c2hs ==0.28.6,
+             c2hs +base3 -regression,
              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.concurrent-output ==1.10.11,
-             any.conduit-extra ==1.3.4,
+             any.conduit ==1.3.2,
-             any.containers ==0.6.0.1,
+             any.conduit-extra ==1.3.5,
+             any.containers ==0.6.2.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.6.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.dlist ==0.8.0.8,
              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.extra ==1.7.1,
              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.generics-sop ==0.5.1.0,
-             any.ghc-boot-th ==8.6.5,
+             any.ghc-boot-th ==8.8.3,
              any.ghc-prim ==0.5.3,
              any.happy ==1.19.12,
              happy +small_base,
@@ -108,7 +101,7 @@ constraints: any.Cabal ==2.4.0.1,
              any.hpath-filepath ==0.10.4,
              any.hpath-io ==0.13.1,
              any.hpath-posix ==0.13.1,
-             any.hsc2hs ==0.68.6,
+             any.hsc2hs ==0.68.7,
              hsc2hs -in-ghc-tree,
              any.http-io-streams ==0.1.2.0,
              http-io-streams -brotli,
@@ -118,9 +111,9 @@ constraints: any.Cabal ==2.4.0.1,
              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.language-c ==0.8.3,
+             language-c -allwarnings +iecfpextension +separatesyb +usebytestrings,
              any.lifted-base ==0.2.3.12,
              any.list-t ==1.0.4,
              any.lockfree-queue ==0.2.3.1,
@@ -129,16 +122,12 @@ constraints: any.Cabal ==2.4.0.1,
              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,
@@ -153,8 +142,7 @@ constraints: any.Cabal ==2.4.0.1,
              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.14.0,
-             any.parsec ==3.1.13.0,
              any.parser-combinators ==1.2.1,
              parser-combinators -dev,
              any.pretty ==1.1.3.6,
@@ -164,7 +152,7 @@ constraints: any.Cabal ==2.4.0.1,
              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.process ==1.6.8.0,
              any.profunctors ==5.5.2,
              any.random ==1.1,
              any.recursion-schemes ==5.1.3,
@@ -182,11 +170,10 @@ constraints: any.Cabal ==2.4.0.1,
              semigroupoids +comonad +containers +contravariant +distributive +doctests +tagged +unordered-containers,
              any.semigroups ==0.19.1,
              semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,
-             any.sop-core ==0.5.0.0,
+             any.sop-core ==0.5.0.1,
              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,
@@ -202,26 +189,23 @@ constraints: any.Cabal ==2.4.0.1,
              any.tagged ==0.8.6,
              tagged +deepseq +transformers,
              any.tar-bytestring ==0.6.3.1,
-             any.tasty ==1.2.3,
+             any.template-haskell ==2.15.0.0,
-             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 ==1.2.4.0,
              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-expand-syns ==0.4.6.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 ==1.9.3,
-             any.time-compat ==1.9.2.2,
+             any.time-compat ==1.9.3,
              time-compat -old-locale,
              any.transformers ==0.5.6.2,
              any.transformers-base ==0.4.5.2,
@@ -229,7 +213,6 @@ constraints: any.Cabal ==2.4.0.1,
              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,
@@ -246,12 +229,9 @@ constraints: any.Cabal ==2.4.0.1,
              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,

docker/build.sh

@@ -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'
+

ghcup.cabal

@@ -1,236 +1,382 @@
-cabal-version:       2.2
+cabal-version:      3.0
+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.
 
-name:                ghcup
+homepage:           https://github.com/hasufell/ghcup-hs
-version:             0.1.0.0
+bug-reports:        https://github.com/hasufell/ghcup-hs/issues
-synopsis:            ghc toolchain installer as an exe/library
+license:            LGPL-3.0-only
-description:         A rewrite of the shell script ghcup, for providing
+license-file:       LICENSE
-                     a more stable user experience and exposing an API.
+author:             Julian Ospald
-homepage:            https://github.com/hasufell/ghcup-hs
+maintainer:         hasufell@posteo.de
-bug-reports:         https://github.com/hasufell/ghcup-hs/issues
+copyright:          Julian Ospald 2020
-license:             LGPL-3.0-only
+category:           System
-license-file:        LICENSE
+build-type:         Simple
-author:              Julian Ospald
+extra-source-files: CHANGELOG.md
-maintainer:          hasufell@posteo.de
-copyright:           Julian Ospald 2020
-category:            System
-build-type:          Simple
-extra-source-files:  CHANGELOG.md
 
 source-repository head
-  type: git
+  type:     git
   location: https://github.com/hasufell/ghcup-hs
 
-common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 }
+flag Curl
-common aeson { build-depends: aeson >= 1.4 }
+  description: Use curl instead of http-io-streams for download
-common aeson-pretty { build-depends: aeson-pretty >= 0.8.8 }
+  default:     False
-common ascii-string { build-depends: ascii-string >= 1.0 }
+  manual:      True
-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 megaparsec { build-depends: megaparsec >= 3.5.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 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 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 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 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 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
+  default-language:   Haskell2010
-  ghc-options:          -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded
+  ghc-options:
-  default-extensions:     LambdaCase
+    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-                        , MultiWayIf
+    -fwarn-incomplete-record-updates -threaded
-                        , PackageImports
+
-                        , RecordWildCards
+  default-extensions:
-                        , ScopedTypeVariables
+    LambdaCase
-                        , StrictData
+    MultiWayIf
-                        , Strict
+    PackageImports
-                        , TupleSections
+    RecordWildCards
+    ScopedTypeVariables
+    Strict
+    StrictData
+    TupleSections
 
 library
-  import:              config
+  import:
-                     , base
+    config
-                       -- deps
+    , base
-                     , HsOpenSSL
+    , HsOpenSSL
-                     , aeson
+    , aeson
-                     , ascii-string
+    , ascii-string
-                     , async
+    , async
-                     , attoparsec
+    , attoparsec
-                     , binary
+    , binary
-                     , bytestring
+    , bytestring
-                     , bzlib
+    , bz2
-                     , case-insensitive
+    , case-insensitive
-                     , containers
+    , concurrent-output
-                     , generics-sop
+    , containers
-                     , haskus-utils-types
+    , generics-sop
-                     , haskus-utils-variant
+    , haskus-utils-types
-                     , hopenssl
+    , haskus-utils-variant
-                     , hpath
+    , hopenssl
-                     , hpath-directory
+    , hpath
-                     , hpath-filepath
+    , hpath-directory
-                     , hpath-io
+    , hpath-filepath
-                     , hpath-posix
+    , hpath-io
-                     , http-io-streams
+    , hpath-posix
-                     , io-streams
+    , language-bash
-                     , language-bash
+    , lzma
-                     , lzma
+    , monad-logger
-                     , monad-logger
+    , mtl
-                     , mtl
+    , optics
-                     , optics
+    , optics-vl
-                     , optics-vl
+    , parsec
-                     , parsec
+    , pretty-terminal
-                     , pretty-terminal
+    , regex-posix
-                     , regex-posix
+    , resourcet
-                     , resourcet
+    , safe
-                     , safe
+    , safe-exceptions
-                     , safe-exceptions
+    , streamly
-                     , streamly
+    , streamly-posix
-                     , streamly-posix
+    , streamly-bytestring
-                     , streamly-bytestring
+    , strict-base
-                     , strict-base
+    , string-interpolate
-                     , string-interpolate
+    , tar-bytestring
-                     , tar-bytestring
+    , template-haskell
-                     , template-haskell
+    , text
-                     , terminal-progress-bar
+    , time
-                     , text
+    , transformers
-                     , time
+    , unix
-                     , transformers
+    , unix-bytestring
-                     , unix
+    , uri-bytestring
-                     , unix-bytestring
+    , utf8-string
-                     , uri-bytestring
+    , vector
-                     , utf8-string
+    , versions
-                     , vector
+    , word8
-                     , versions
+    , zlib
-                     , word8
+
-                     , zlib
+  -- deps
-  exposed-modules:     GHCup
+  -- cabal-fmt: expand lib
-                       GHCup.Download
+  exposed-modules:
-                       GHCup.Errors
+    GHCup
-                       GHCup.Platform
+    GHCup.Download
-                       GHCup.Types
+    GHCup.Download.Utils
-                       GHCup.Types.JSON
+    GHCup.Errors
-                       GHCup.Types.Optics
+    GHCup.Platform
-                       GHCup.Utils
+    GHCup.Types
-                       GHCup.Utils.Bash
+    GHCup.Types.JSON
-                       GHCup.Utils.Dirs
+    GHCup.Types.Optics
-                       GHCup.Utils.File
+    GHCup.Utils
-                       GHCup.Utils.Logger
+    GHCup.Utils.Bash
-                       GHCup.Utils.Prelude
+    GHCup.Utils.Dirs
-                       GHCup.Utils.String.QQ
+    GHCup.Utils.File
-                       GHCup.Utils.Version.QQ
+    GHCup.Utils.Logger
-                       GHCup.Version
+    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:
+      , http-io-streams
+      , io-streams
+      , terminal-progress-bar
+    exposed-modules: GHCup.Download.IOStreams
+  else
+    cpp-options:     -DCURL
 
 executable ghcup
-  import:                config
+  import:
-                       , base
+    config
-                       --
+    , base
-                       , bytestring
+    , bytestring
-                       , containers
+    , containers
-                       , haskus-utils-variant
+    , haskus-utils-variant
-                       , monad-logger
+    , hpath
-                       , megaparsec
+    , hpath-io
-                       , mtl
+    , megaparsec
-                       , optparse-applicative
+    , monad-logger
-                       , text
+    , mtl
-                       , versions
+    , optparse-applicative
-                       , hpath
+    , pretty-terminal
-                       , hpath-io
+    , resourcet
-                       , pretty-terminal
+    , string-interpolate
-                       , resourcet
+    , table-layout
-                       , string-interpolate
+    , text
-                       , table-layout
+    , uri-bytestring
-                       , uri-bytestring
+    , utf8-string
-                       , utf8-string
+    , versions
-  main-is:             Main.hs
+
+  --
+  main-is:          Main.hs
+
   -- other-modules:
   -- other-extensions:
-  build-depends:       ghcup
+  build-depends:    ghcup
-  hs-source-dirs:      app/ghcup
+  hs-source-dirs:   app/ghcup
-  default-language:    Haskell2010
+  default-language: Haskell2010
 
 executable ghcup-gen
-  import:                config
+  import:
-                       , base
+    config
-                       --
+    , base
-                       , aeson
+    , aeson
-                       , aeson-pretty
+    , aeson-pretty
-                       , bytestring
+    , bytestring
-                       , containers
+    , containers
-                       , safe-exceptions
+    , haskus-utils-variant
-                       , haskus-utils-variant
+    , hpath
-                       , monad-logger
+    , monad-logger
-                       , mtl
+    , mtl
-                       , optics
+    , optics
-                       , optparse-applicative
+    , optparse-applicative
-                       , text
+    , pretty-terminal
-                       , versions
+    , resourcet
-                       , hpath
+    , safe-exceptions
-                       , pretty-terminal
+    , string-interpolate
-                       , resourcet
+    , table-layout
-                       , string-interpolate
+    , text
-                       , table-layout
+    , transformers
-                       , transformers
+    , uri-bytestring
-                       , uri-bytestring
+    , utf8-string
-                       , utf8-string
+    , versions
-  main-is:             Main.hs
+
-  other-modules:       GHCupDownloads
+  --
-                       Validate
+  main-is:          Main.hs
+  other-modules: GHCupDownloads
+                 Validate
+
   -- other-extensions:
-  build-depends:       ghcup
+  build-depends:    ghcup
-  hs-source-dirs:      app/ghcup-gen
+  hs-source-dirs:   app/ghcup-gen
-  default-language:    Haskell2010
+  default-language: Haskell2010
 
 test-suite ghcup-test
-  default-language:    Haskell2010
+  default-language: Haskell2010
-  type:                exitcode-stdio-1.0
+  type:             exitcode-stdio-1.0
-  hs-source-dirs:      test
+  hs-source-dirs:   test
-  main-is:             MyLibTest.hs
+  main-is:          MyLibTest.hs
-  build-depends:       base ^>=4.12.0.0
+  build-depends:    base >=4.12.0.0

lib/GHCup.hs

@@ -28,10 +28,8 @@ import           GHCup.Version
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
-import           Control.Monad.Fail             ( MonadFail )
 import           Control.Monad.Logger
 import           Control.Monad.Reader
-import           Control.Monad.Trans.Class      ( lift )
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
 import           Data.ByteString                ( ByteString )
@@ -51,8 +49,6 @@ 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
@@ -138,7 +134,7 @@ installGHCBin bDls ver mpfReq = do
     lEM $ liftIO $ execLogged "./configure"
                               False
                               ["--prefix=" <> toFilePath inst]
-                              [rel|ghc-configure.log|]
+                              [rel|ghc-configure|]
                               (Just path)
                               Nothing
     lEM $ liftIO $ make ["install"] (Just path)
@@ -435,10 +431,11 @@ compileGHC :: ( MonadMask m
               , MonadFail m
               )
            => GHCupDownloads
-           -> Version          -- ^ version to install
+           -> Version                    -- ^ version to install
-           -> Version          -- ^ version to bootstrap with
+           -> Either Version (Path Abs)  -- ^ version to bootstrap with
-           -> Maybe Int        -- ^ jobs
+           -> Maybe Int                  -- ^ jobs
-           -> Maybe (Path Abs) -- ^ build config
+           -> Maybe (Path Abs)           -- ^ build config
+           -> Maybe (Path Abs)
            -> Excepts
                 '[ AlreadyInstalled
                  , BuildFailed
@@ -446,12 +443,13 @@ compileGHC :: ( MonadMask m
                  , DownloadFailed
                  , GHCupSetError
                  , NoDownload
+                 , PatchFailed
                  , UnknownArchive
                  ]
                 m
                 ()
-compileGHC dls tver bver jobs mbuildConfig = do
+compileGHC dls tver bstrap jobs mbuildConfig patchdir = do
-  lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
+  lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
   whenM (liftIO $ toolAlreadyInstalled GHC tver)
         (throwE $ AlreadyInstalled GHC tver)
 
@@ -463,7 +461,9 @@ compileGHC dls tver bver jobs mbuildConfig = do
   tmpUnpack <- lift mkGhcupTmpDir
   liftE $ unpackToDir tmpUnpack dl
 
-  bghc <- parseRel ("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
 
@@ -495,36 +495,47 @@ 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]
+               '[ NoDownload
+                , FileDoesNotExistError
+                , PatchFailed
+                , 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
-        spaths   <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
+        bghcPath <- case bghc of
-        bghcPath <- (liftIO $ searchPath spaths bghc) !? NoDownload
+          Right ghc' -> pure ghc'
+          Left  bver -> do
+            spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
+            (liftIO $ searchPath spaths bver) !? NoDownload
         lEM $ liftIO $ execLogged
           "./configure"
           False
           ["--prefix=" <> toFilePath ghcdir]
-          [rel|ghc-configure.log|]
+          [rel|ghc-conf|]
           (Just workdir)
           (Just (("GHC", toFilePath bghcPath) : newEnv))
       | otherwise -> do
         lEM $ liftIO $ execLogged
           "./configure"
           False
-          ["--prefix=" <> toFilePath ghcdir, "--with-ghc=" <> toFilePath bghc]
+          [ "--prefix=" <> toFilePath ghcdir
-          [rel|ghc-configure.log|]
+          , "--with-ghc=" <> either toFilePath toFilePath bghc
+          ]
+          [rel|ghc-conf|]
           (Just workdir)
           (Just newEnv)
 
@@ -536,9 +547,7 @@ GhcWithLlvmCodeGen = YES|]
       Nothing ->
         liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
 
-    lift
+    lift $ $(logInfo) [i|Building (this may take a while)...|]
-      $ $(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)
 
@@ -560,19 +569,21 @@ 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
                    , DownloadFailed
                    , NoDownload
+                   , PatchFailed
                    , UnknownArchive
                    ]
                   m
                   ()
-compileCabal dls tver bver jobs = do
+compileCabal dls tver bghc jobs patchdir = do
-  lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bver}|]
+  lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
 
   -- download source tarball
   dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
@@ -592,27 +603,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
+    lift $ $(logInfo) [i|Building (this may take a while)...|]
-      $ $(logInfo)
+
-          [i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/cabal-bootstrap.log' to see the progress.|]
+    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
+    newEnv    <- lift
-      [ ("GHC"    , "ghc-" <> v')
+      $ addToCurrentEnv (("PREFIX", toFilePath cabal_bin) : ghcEnv)
-      , ("GHC_PKG", "ghc-pkg-" <> v')
+    lift $ $(logDebug) [i|Environment: #{newEnv}|]
-      , ("GHC_VER", v')
-      , ("PREFIX" , toFilePath cabal_bin)
-      ]
 
     lEM $ liftIO $ execLogged "./bootstrap.sh"
                               False
                               (maybe [] (\j -> ["-j", fS (show j)]) jobs)
-                              [rel|cabal-bootstrap.log|]
+                              [rel|cabal-bootstrap|]
                               (Just workdir)
                               (Just newEnv)
 

lib/GHCup/Download.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE FlexibleContexts      #-}
@@ -10,33 +11,34 @@
 
 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
+#if defined(CURL)
 import           GHCup.Utils.File
+#endif
 import           GHCup.Utils.Prelude
+import           GHCup.Version
 
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
-import           Control.Monad.Fail             ( MonadFail )
 import           Control.Monad.Logger
 import           Control.Monad.Reader
-import           Control.Monad.Trans.Class      ( lift )
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
 import           Data.Aeson
 import           Data.ByteString                ( ByteString )
-import           Data.ByteString.Builder
 import           Data.CaseInsensitive           ( CI )
-import           Data.IORef
 import           Data.Maybe
 import           Data.String.Interpolate
-import           Data.Text.Read
 import           Data.Time.Clock
 import           Data.Time.Clock.POSIX
 import           Data.Time.Format
@@ -45,7 +47,6 @@ 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
@@ -53,32 +54,19 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           System.IO.Error
-import "unix"    System.Posix.IO.ByteString
-                                         hiding ( fdWrite )
-import "unix-bytestring" System.Posix.IO.ByteString
-                                                ( fdWrite )
-import           System.Posix.RawFilePath.Directory.Errors
-                                                ( hideError )
-import           System.ProgressBar
 import           URI.ByteString
-import           URI.ByteString.QQ
 
-import qualified Data.Binary.Builder           as B
-import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.CaseInsensitive          as CI
 import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
-import qualified System.IO.Streams             as Streams
 import qualified System.Posix.Files.ByteString as PF
 import qualified System.Posix.RawFilePath.Directory
                                                as RD
 
 
 
-ghcupURL :: URI
-ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
 
 
 
@@ -130,6 +118,7 @@ getDownloads urlSource = do
                 , UnsupportedScheme
                 , NoLocationHeader
                 , TooManyRedirs
+                , ProcessError
                 ]
                m1
                L.ByteString
@@ -158,7 +147,7 @@ getDownloads urlSource = 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
@@ -171,11 +160,14 @@ getDownloads urlSource = do
             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
@@ -186,7 +178,7 @@ getDownloads urlSource = do
           $ getHead uri'
           )
       pure $ parseModifiedHeader headers
-
+#endif
 
   parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
   parseModifiedHeader headers =
@@ -289,25 +281,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)
-      $ flip finally (liftIO $ closeFd fd)
+     $ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
-      $ catchAllE
           (\e ->
             (liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
               >> (throwE . DownloadFailed $ e)
-          )
+          ) $ do
-      $ downloadInternal True https host fullPath port stepper
+#if defined(CURL)
+              liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
+                ["-sSfL", "-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
@@ -356,6 +348,8 @@ downloadCached dli mfn = do
     ------------------
 
 
+
+
 -- | This is used for downloading the JSON.
 downloadBS :: (MonadCatch m, MonadIO m)
            => URI
@@ -366,6 +360,7 @@ downloadBS :: (MonadCatch m, MonadIO m)
                  , UnsupportedScheme
                  , NoLocationHeader
                  , TooManyRedirs
+                 , ProcessError
                  ]
                 m
                 L.ByteString
@@ -384,220 +379,17 @@ downloadBS uri'
   scheme = view (uriSchemeL' % schemeBSL') uri'
   path   = view pathL' uri'
   dl https = do
+#if defined(CURL)
+    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
     (_, 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)
@@ -613,3 +405,4 @@ checkDigest dli file = do
     let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
         eDigest = view dlHash dli
     when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
+

lib/GHCup/Download/IOStreams.hs

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

lib/GHCup/Download/Utils.hs

@@ -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
+

lib/GHCup/Errors.hs

@@ -88,6 +88,10 @@ data NoLocationHeader = NoLocationHeader
 data TooManyRedirs = TooManyRedirs
   deriving Show
 
+-- | A patch could not be applied.
+data PatchFailed = PatchFailed
+  deriving Show
+
 
 
     -------------------------

lib/GHCup/Platform.hs

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

lib/GHCup/Types/JSON.hs

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

lib/GHCup/Utils.hs

@@ -22,10 +22,8 @@ import           GHCup.Utils.Prelude
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
-import           Control.Monad.Fail             ( MonadFail )
 import           Control.Monad.Logger
 import           Control.Monad.Reader
-import           Control.Monad.Trans.Class      ( lift )
 import           Data.Attoparsec.ByteString
 import           Data.ByteString                ( ByteString )
 import           Data.List
@@ -335,4 +333,24 @@ 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.log|] workdir Nothing
+  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

lib/GHCup/Utils/File.hs

@@ -1,18 +1,22 @@
-{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# 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,16 @@ 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
+
+
+data StopThread = StopThread Bool
+  deriving Show
+
+instance Exception StopThread
 
 
 data ProcessError = NonZeroExit Int ByteString [ByteString]
@@ -99,7 +119,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 +136,110 @@ execLogged :: ByteString       -- ^ thing to execute
            -> Maybe [(ByteString, ByteString)] -- ^ optional environment
            -> IO (Either ProcessError ())
 execLogged exe spath args lfile chdir env = do
-  ldir <- ghcupLogsDir
+  ldir    <- ghcupLogsDir
-  let logfile = ldir </> lfile
+  logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
   bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
  where
   action fd = do
-    pid <- SPPB.forkProcess $ do
+    actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-      -- dup stdout
+      -- start the thread that logs to stdout in a region
-      void $ dupTo fd stdOutput
+      done <- newEmptyMVar
+      tid  <-
+        forkIO
+        $ EX.handle (\(_ :: StopThread) -> pure ())
+        $ EX.handle (\(_ :: IOException) -> pure ())
+        $ flip finally (putMVar done ())
+        $ printToRegion fd stdoutRead 6
 
-      -- dup stderr
+      -- fork our subprocess
-      void $ dupTo fd stdError
+      pid <- SPPB.forkProcess $ do
+        void $ dupTo stdoutWrite stdOutput
+        void $ dupTo stdoutWrite stdError
+        closeFd stdoutWrite
+        closeFd stdoutRead
 
-      -- execute the action
+        -- execute the action
-      maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+        maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
-      SPPB.executeFile exe spath args env
+        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)
+            )
+        $ readForever (lineAction ref rs) 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")
 
 
-    SPPB.getProcessStatus True True pid >>= \case
+    swapRegs bs regs | length regs < size = regs ++ [bs]
-      i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
+                     | otherwise          = tail regs ++ [bs]
-      i                         -> pure $ toProcessError exe args i
+
+    -- 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 <-
+        handle
+            (\(e :: IOError) -> do
+              if isEOFError e then threadDelay 1000 >> pure "" else throw e
+            )
+          $ SPIB.fdRead fd' 1
+      if
+        | bs == "\n" -> pure ""
+        | bs == ""   -> pure ""
+        | otherwise  -> fmap (bs <>) $ readLine fd'
+
+    readForever action' fd' = do
+      bs <- readLine fd'
+      if not $ BS.null bs
+        then action' bs >> readForever action' fd'
+        else readForever action' fd'
+
+    readTilEOF action' fd' = do
+      bs <- readLine fd'
+      when (not $ BS.null bs) (action' bs >> readTilEOF action' fd')
 
 
 -- | Capture the stdout and stderr of the given action, which
@@ -144,7 +248,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 +263,67 @@ 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
+          stdout' <- readIORef refOut
-          stderr' <- L.toStrict <$> readFd parentStderrRead
+          stderr' <- readIORef refErr
           pure $ CapturedProcess { _exitCode = es
                                  , _stdOut   = stdout'
                                  , _stdErr   = stderr'
                                  }
+
         _ -> throwIO $ userError $ ("No such PID " ++ show pid)
 
  where
-  actionWithPipes a =
+  writeStds pout perr rout rerr = do
-    createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
+    doneOut <- newEmptyMVar
-  cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
+    void
+      $ forkIO
+      $ EX.handle (\(_ :: IOException) -> pure ())
+      $ flip finally (putMVar doneOut ())
+      $ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
+    doneErr <- newEmptyMVar
+    void
+      $ forkIO
+      $ EX.handle (\(_ :: IOException) -> pure ())
+      $ flip finally (putMVar doneErr ())
+      $ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
+    takeMVar doneOut
+    takeMVar doneErr
+
+  readTilEOF action' fd' = do
+    bs <- SPIB.fdRead fd' 512
+    when (not $ BS.null bs) (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
 
 
 

lib/GHCup/Utils/Prelude.hs

@@ -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

lib/GHCup/Utils/Version/QQ.hs

@@ -11,11 +11,9 @@ module GHCup.Utils.Version.QQ where
 import           Data.Data
 import           Data.Text                      ( Text )
 import           Data.Versions
-import           GHC.Base
 import           Language.Haskell.TH
 import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
-import           Language.Haskell.TH.Syntax     ( Exp(..)
+import           Language.Haskell.TH.Syntax     ( Lift
-                                                , Lift
                                                 , dataToExpQ
                                                 )
 import qualified Data.Text                     as T
@@ -33,12 +31,10 @@ deriving instance Data Mess
 deriving instance Lift Mess
 deriving instance Data PVP
 deriving instance Lift PVP
-deriving instance Lift (NonEmpty Word)
 deriving instance Lift VSep
 deriving instance Data VSep
 deriving instance Lift VUnit
 deriving instance Data VUnit
-instance Lift Text
 
 qq :: (Text -> Q Exp) -> QuasiQuoter
 qq quoteExp' = QuasiQuoter

lib/GHCup/Version.hs

@@ -6,6 +6,11 @@ module GHCup.Version where
 import           GHCup.Utils.Version.QQ
 
 import           Data.Versions
+import           URI.ByteString
+import           URI.ByteString.QQ
+
+ghcupURL :: URI
+ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
 
 ghcUpVer :: PVP
-ghcUpVer = [pver|0.0.0|]
+ghcUpVer = [pver|0.0.1|]