Yoo

README.md

@@ -1,28 +1,25 @@
 # ghcup
 
-A rewrite of ghcup in haskell. This can be used as a library
-and may be redistributed as a binary in the future.
+A rewrite of ghcup in haskell.
 
 ## Motivation
 
-ghcup has increasingly become difficult to maintain. A few reasons:
+Maintenance problems:
 
-* few maintainers
-* increasing LOC
 * platform incompatibilities regularly causing breaking bugs:
 	* [Mktemp not working properly on macOS](https://gitlab.haskell.org/haskell/ghcup/issues/130)
 	* [ln: illegal option -- T on macOS Catalina](https://gitlab.haskell.org/haskell/ghcup/issues/123)
 	* [Wrong tar flag on darwin](https://gitlab.haskell.org/haskell/ghcup/issues/119))
 * refactoring being difficult due to POSIX sh
 
-More benefits of a rewrite:
+Benefits of a rewrite:
 
 * Features such as installing [release candidates](https://gitlab.haskell.org/haskell/ghcup/issues/94) or [HEAD builds](https://gitlab.haskell.org/haskell/ghcup/issues/65) can be more conveniently implemented in a rewrite
 * Refactoring will be easier
 * Better tool support (such as linting the downloads file)
 * saner downloads file format (such as JSON)
 
-However, the downside will be:
+Downsides:
 
 * building static binaries for all platforms (and possibly causing SSL/DNS problems)
 * still bootstrapping those binaries via a POSIX sh script
@@ -31,4 +28,4 @@ However, the downside will be:
 
 * Correct low-level code
 * Good exception handling
-* Easier user interface (possibly interactive and non-interactive ones)
+* Cleaner user interface

TODO.md

@@ -2,38 +2,40 @@
 
 ## Now
 
-* static builds and host ghcup (and fix BinaryDownloads)
-* interoperability with old ghcup
+* print-system-reqs
 
-* sign the JSON? (Or check gpg keys?)
+## Cleanups
+
+* avoid alternative for IO
+* don't use Excepts?
 
 ## Maybe
 
-* maybe: download progress
 * maybe: changelog          Show the changelog of a GHC release (online)
-* maybe: print-system-reqs  Print an approximation of system requirements
 * OS faking
+* sign the JSON? (Or check gpg keys?)
 
 * testing (especially distro detection -> unit tests)
 
+* hard cleanup command?
+
 ## Later
 
+* static builds and host ghcup
+* do bootstrap-haskell with new ghcup
 * add support for RC/alpha/HEAD versions
 * check for updates on start
 * use plucky or oops instead of Excepts
 
 ## Questions
 
-* how to figure out tools (currently not done, but when setting ghc symlinks, removes all previous tools before symlinking requested version to avoid stale tools that only exist for one version)
 * handling of SIGTERM and SIGUSR
 * installing musl on demand?
 * redo/rethink how tool tags works
+  * tarball tags as well as version tags?
 * mirror support
 * check for new version on start
-* tarball tags as well as version tags?
-* installing multiple versions in parallel?
-* how to version and extend the format of the downloads file? Compatibility?
-* how to propagate updates? Automatically? Might solve the versioning problem
+  * how to propagate updates? Automatically? Might solve the versioning problem
+  * maybe add deprecation notice into JSON
 * 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?
-* maybe add deprecation notice into JSON

app/ghcup-gen/SourceDownloads.hs

@@ -1,26 +0,0 @@
-{-# LANGUAGE QuasiQuotes       #-}
-
-module SourceDownloads where
-
-
-import           GHCup.Types
-import           GHCup.Utils.String.QQ
-import           GHCup.Utils.Version.QQ
-
-import           HPath
-import           URI.ByteString.QQ
-
-import qualified Data.Map                      as M
-
-
--- TODO: source tarballs
--- TODO: reference tarballs
-sourceDownloads :: SourceDownloads
-sourceDownloads = M.fromList
-  [ ( [vver|8.6.5|]
-    , DownloadInfo
-      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-src.tar.xz|]
-      (Just ([rel|ghc-8.6.5|] :: Path Rel))
-      [s|b47726aaf302eb87b4970fcee924d45d|]
-    )
-  ]

app/ghcup-gen/Validate.hs

@@ -7,7 +7,6 @@ module Validate where
 import           GHCup
 import           GHCup.Download
 import           GHCup.Types
-import           GHCup.Types.Optics
 import           GHCup.Utils.Logger
 
 import           Control.Exception.Safe
@@ -48,22 +47,22 @@ addError = do
 validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
          => GHCupDownloads
          -> m ExitCode
-validate dls@GHCupDownloads {..} = do
+validate dls = do
   ref <- liftIO $ newIORef 0
 
   -- * verify binary downloads * --
   flip runReaderT ref $ do
     -- unique tags
-    forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkUniqueTags t
+    forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
 
     -- required platforms
-    forM_ (M.toList _binaryDownloads) $ \(t, versions) ->
+    forM_ (M.toList dls) $ \(t, versions) ->
       forM_ (M.toList versions) $ \(v, vi) ->
         forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
           checkHasRequiredPlatforms t v arch (M.keys pspecs)
 
     checkGHCisSemver
-    forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkMandatoryTags t
+    forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
 
     -- exit
     e <- liftIO $ readIORef ref
@@ -86,7 +85,7 @@ validate dls@GHCupDownloads {..} = do
       [i|FreeBSD missing for #{t} #{v'} #{arch}|]
 
   checkUniqueTags tool = do
-    let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool
+    let allTags = join $ fmap snd $ availableToolVersions dls tool
     let nonUnique =
           fmap fst
             .   filter (\(_, b) -> not b)
@@ -110,7 +109,7 @@ validate dls@GHCupDownloads {..} = do
     isUniqueTag Recommended = True
 
   checkGHCisSemver = do
-    let ghcVers = toListOf (binaryDownloads % ix GHC % to M.keys % folded) dls
+    let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
     forM_ ghcVers $ \v -> case semver (prettyVer v) of
       Left _ -> do
         lift $ $(logError) [i|GHC version #{v} is not valid semver|]
@@ -119,7 +118,7 @@ validate dls@GHCupDownloads {..} = do
 
   -- a tool must have at least one of each mandatory tags
   checkMandatoryTags tool = do
-    let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool
+    let allTags = join $ fmap snd $ availableToolVersions dls tool
     forM_ [Latest, Recommended] $ \t -> case elem t allTags of
       False -> do
         lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
@@ -132,20 +131,25 @@ validateTarballs :: ( Monad m
                     , MonadThrow m
                     , MonadIO m
                     , MonadUnliftIO m
+                    , MonadMask m
                     )
                  => GHCupDownloads
                  -> m ExitCode
-validateTarballs GHCupDownloads {..} = do
+validateTarballs dls = do
   ref <- liftIO $ newIORef 0
 
   flip runReaderT ref $ do
-      -- download/verify all tarballs
+     -- download/verify all binary tarballs
     let
-      dlis = nub $ join $ (M.elems _binaryDownloads) <&> \versions ->
+      dlbis = nub $ join $ (M.elems dls) <&> \versions ->
         join $ (M.elems versions) <&> \vi ->
           join $ (M.elems $ _viArch vi) <&> \pspecs ->
             join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
-    forM_ dlis $ downloadAll
+    forM_ dlbis $ downloadAll
+
+    let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
+          join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
+    forM_ dlsrc $ downloadAll
 
     -- exit
     e <- liftIO $ readIORef ref

app/ghcup/Main.hs

@@ -13,10 +13,10 @@ import           GHCup.Download
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils
-import           GHCup.Utils.File
 import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
 import           GHCup.Utils.String.QQ
+import           GHCup.Version
 
 import           Control.Monad.Logger
 import           Control.Monad.Reader
@@ -43,6 +43,7 @@ import           URI.ByteString
 import qualified Data.ByteString               as B
 import qualified Data.ByteString.UTF8          as UTF8
 import qualified Data.Text                     as T
+import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as E
 
 
@@ -66,8 +67,9 @@ data Command
   | List ListOptions
   | Rm RmOptions
   | DInfo
-  | Compile CompileOptions
+  | Compile CompileCommand
   | Upgrade UpgradeOpts
+  | NumericVersion
 
 data ToolVersion = ToolVersion Version
                  | ToolTag Tag
@@ -94,8 +96,12 @@ data RmOptions = RmOptions
   }
 
 
+data CompileCommand = CompileGHC CompileOptions
+                    | CompileCabal CompileOptions
+
+
 data CompileOptions = CompileOptions
-  { ghcVer       :: Version
+  { targetVer    :: Version
   , bootstrapVer :: Version
   , jobs         :: Maybe Int
   , buildConfig  :: Maybe (Path Abs)
@@ -122,21 +128,20 @@ opts =
           (option
             (eitherReader parseUri)
             (short 's' <> long "url-source" <> metavar "URL" <> help
-              "Alternative ghcup download info url"
+              "Alternative ghcup download info url" <> internal
             )
           )
         )
     <*> switch
-          (  short 'n'
-          <> long "no-verify"
-          <> help
-               "Skip tarball checksum checks (default: False)"
+          (short 'n' <> long "no-verify" <> help
+            "Skip tarball checksum verification (default: False)"
           )
     <*> com
  where
   parseUri s' =
     bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
 
+
 com :: Parser Command
 com =
   subparser
@@ -162,6 +167,13 @@ com =
                  (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
                )
            )
+          <> command
+               "compile"
+               (   Compile
+               <$> (info (compileP <**> helper)
+                         (progDesc "Compile a tool from source")
+                   )
+               )
       <> commandGroup "Main commands:"
       )
     <|> subparser
@@ -180,13 +192,6 @@ com =
                      (progDesc "Remove a GHC version installed by ghcup")
                    )
                )
-          <> command
-               "compile"
-               (   Compile
-               <$> (info (compileOpts <**> helper)
-                         (progDesc "Compile GHC from source")
-                   )
-               )
           <> commandGroup "GHC commands:"
           <> hidden
           )
@@ -194,6 +199,11 @@ com =
           (  command
               "debug-info"
               ((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
+          <> command
+               "numeric-version"
+               (   (\_ -> NumericVersion)
+               <$> (info (helper) (progDesc "Show the numeric version"))
+               )
           <> commandGroup "Other commands:"
           <> hidden
           )
@@ -246,6 +256,24 @@ rmOpts :: Parser RmOptions
 rmOpts = RmOptions <$> versionParser
 
 
+compileP :: Parser CompileCommand
+compileP = subparser
+  (  command
+      "ghc"
+      (   CompileGHC
+      <$> (info (compileOpts <**> helper) (progDesc "Compile GHC from source")
+          )
+      )
+  <> command
+       "cabal"
+       (   CompileCabal
+       <$> (info (compileOpts <**> helper)
+                 (progDesc "Compile Cabal from source")
+           )
+       )
+  )
+
+
 compileOpts :: Parser CompileOptions
 compileOpts =
   CompileOptions
@@ -254,7 +282,7 @@ compileOpts =
             (bimap (const "Not a valid version") id . version . T.pack)
           )
           (short 'v' <> long "version" <> metavar "VERSION" <> help
-            "The GHC version to compile"
+            "The tool version to compile"
           )
         )
     <*> (option
@@ -362,8 +390,6 @@ upgradeOptsP =
 
 
 
--- TODO: something better than Show instance for errors
-
 main :: IO ()
 main = do
 
@@ -386,19 +412,19 @@ main = do
                   . runResourceT
                   . runE
                     @'[ AlreadyInstalled
-                      , ArchiveError
+                      , UnknownArchive
                       , DistroNotFound
                       , FileDoesNotExistError
-                      , FileError
+                      , CopyError
                       , JSONError
                       , NoCompatibleArch
                       , NoDownload
                       , NotInstalled
-                      , PlatformResultError
-                      , ProcessError
+                      , NoCompatiblePlatform
+                      , BuildFailed
                       , TagNotFound
-                      , URLException
                       , DigestError
+                      , DownloadFailed
                       ]
 
           let runSetGHC =
@@ -408,15 +434,15 @@ main = do
                     @'[ FileDoesNotExistError
                       , NotInstalled
                       , TagNotFound
-                      , URLException
                       , JSONError
                       , TagNotFound
+                      , DownloadFailed
                       ]
 
           let runListGHC =
                 runLogger
                   . flip runReaderT settings
-                  . runE @'[FileDoesNotExistError , URLException , JSONError]
+                  . runE @'[FileDoesNotExistError , JSONError , DownloadFailed]
 
           let runRmGHC =
                 runLogger . flip runReaderT settings . runE @'[NotInstalled]
@@ -425,7 +451,7 @@ main = do
                 runLogger
                   . flip runReaderT settings
                   . runE
-                    @'[PlatformResultError , NoCompatibleArch , DistroNotFound]
+                    @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
 
           let runCompileGHC =
                 runLogger
@@ -433,31 +459,43 @@ main = do
                   . runResourceT
                   . runE
                     @'[ AlreadyInstalled
-                      , NotInstalled
-                      , GHCNotFound
-                      , ArchiveError
-                      , ProcessError
-                      , URLException
+                      , BuildFailed
                       , DigestError
-                      , BuildConfigNotFound
-                      , FileDoesNotExistError
-                      , URLException
+                      , DownloadFailed
+                      , GHCupSetError
+                      , NoDownload
+                      , UnknownArchive
+                     --
                       , JSONError
                       ]
 
+          let runCompileCabal =
+                runLogger
+                  . flip runReaderT settings
+                  . runResourceT
+                  . runE
+                    @'[ JSONError
+                      , UnknownArchive
+                      , NoDownload
+                      , DigestError
+                      , DownloadFailed
+                      , BuildFailed
+                      ]
+
           let runUpgrade =
                 runLogger
                   . flip runReaderT settings
                   . runResourceT
                   . runE
                     @'[ DigestError
-                      , URLException
                       , DistroNotFound
-                      , PlatformResultError
+                      , NoCompatiblePlatform
                       , NoCompatibleArch
                       , NoDownload
                       , FileDoesNotExistError
                       , JSONError
+                      , DownloadFailed
+                      , CopyError
                       ]
 
 
@@ -465,16 +503,22 @@ main = do
             Install (InstallGHC InstallOptions {..}) ->
               void
                 $   (runInstTool $ do
-                      dls <- _binaryDownloads <$> liftE getDownloads
+                      dls <- liftE getDownloads
                       v   <- liftE $ fromVersion dls instVer GHC
-                      liftE $ installTool dls (ToolRequest GHC v) Nothing
+                      liftE $ installGHCBin dls v Nothing
                     )
                 >>= \case
                       VRight _ -> runLogger
                         $ $(logInfo) ([s|GHC installation successful|])
-                      VLeft (V (AlreadyInstalled treq)) ->
+                      VLeft (V (AlreadyInstalled _ v)) ->
                         runLogger $ $(logWarn)
-                          (T.pack (show treq) <> [s| already installed|])
+                          [i|GHC ver #{prettyVer v} already installed|]
+                      VLeft (V (BuildFailed tmpdir e)) ->
+                        runLogger
+                            ($(logError) [i|Build failed with #{e}
+Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
+                            )
+                          >> exitFailure
                       VLeft e -> do
                         runLogger $ do
                           $(logError) [i|#{e}|]
@@ -483,16 +527,16 @@ main = do
             Install (InstallCabal InstallOptions {..}) ->
               void
                 $   (runInstTool $ do
-                      dls <- _binaryDownloads <$> liftE getDownloads
+                      dls <- liftE getDownloads
                       v   <- liftE $ fromVersion dls instVer Cabal
-                      liftE $ installTool dls (ToolRequest Cabal v) Nothing
+                      liftE $ installCabalBin dls v Nothing
                     )
                 >>= \case
                       VRight _ -> runLogger
                         $ $(logInfo) ([s|Cabal installation successful|])
-                      VLeft (V (AlreadyInstalled treq)) ->
+                      VLeft (V (AlreadyInstalled _ v)) ->
                         runLogger $ $(logWarn)
-                          (T.pack (show treq) <> [s| already installed|])
+                          [i|Cabal ver #{prettyVer v} already installed|]
                       VLeft e -> do
                         runLogger $ do
                           $(logError) [i|#{e}|]
@@ -502,7 +546,7 @@ main = do
             SetGHC (SetGHCOptions {..}) ->
               void
                 $   (runSetGHC $ do
-                      dls <- _binaryDownloads <$> liftE getDownloads
+                      dls <- liftE getDownloads
                       v   <- liftE $ fromVersion dls ghcVer GHC
                       liftE $ setGHC v SetGHCOnly
                     )
@@ -515,7 +559,7 @@ main = do
             List (ListOptions {..}) ->
               void
                 $   (runListGHC $ do
-                      dls <- _binaryDownloads <$> liftE getDownloads
+                      dls <- liftE getDownloads
                       liftIO $ listVersions dls lTool lCriteria
                     )
                 >>= \case
@@ -543,24 +587,52 @@ main = do
                       VLeft e ->
                         runLogger ($(logError) [i|#{e}|]) >> exitFailure
 
-            Compile (CompileOptions {..}) ->
+            Compile (CompileGHC CompileOptions {..}) ->
               void
                 $   (runCompileGHC $ do
-                      dls <- _sourceDownloads <$> liftE getDownloads
-                      liftE $ compileGHC dls ghcVer bootstrapVer jobs buildConfig
+                      dls <- liftE getDownloads
+                      liftE
+                        $ compileGHC dls targetVer bootstrapVer jobs buildConfig
                     )
                 >>= \case
                       VRight _ ->
                         runLogger $ $(logInfo)
                           ([s|GHC successfully compiled and installed|])
-                      VLeft (V (AlreadyInstalled treq)) ->
+                      VLeft (V (AlreadyInstalled _ v)) ->
                         runLogger $ $(logWarn)
-                          (T.pack (show treq) <> [s| already installed|])
+                          [i|GHC ver #{prettyVer v} already installed|]
+                      VLeft (V (BuildFailed tmpdir e)) ->
+                        runLogger
+                            ($(logError) [i|Build failed with #{e}
+Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
+                            )
+                          >> exitFailure
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            Compile (CompileCabal CompileOptions {..}) ->
+              void
+                $   (runCompileCabal $ do
+                      dls <- liftE getDownloads
+                      liftE $ compileCabal dls
+                                           targetVer
+                                           bootstrapVer
+                                           jobs
+                    )
+                >>= \case
+                      VRight _ ->
+                        runLogger $ $(logInfo)
+                          ([s|Cabal successfully compiled and installed|])
+                      VLeft (V (BuildFailed tmpdir e)) ->
+                        runLogger
+                            ($(logError) [i|Build failed with #{e}
+Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
+                            )
+                          >> exitFailure
                       VLeft e ->
                         runLogger ($(logError) [i|#{e}|]) >> exitFailure
 
             Upgrade (uOpts) -> do
-              liftIO $ putStrLn $ show uOpts
               target <- case uOpts of
                 UpgradeInplace -> do
                   efp <- liftIO $ getExecutablePath
@@ -573,7 +645,7 @@ main = do
 
               void
                 $   (runUpgrade $ do
-                      dls <- _binaryDownloads <$> liftE getDownloads
+                      dls <- liftE getDownloads
                       liftE $ upgradeGHCup dls target
                     )
                 >>= \case
@@ -585,11 +657,12 @@ main = do
                       VLeft e ->
                         runLogger ($(logError) [i|#{e}|]) >> exitFailure
 
+            NumericVersion -> T.hPutStr stdout (prettyPVP ghcUpVer)
   pure ()
 
 
 fromVersion :: Monad m
-            => BinaryDownloads
+            => GHCupDownloads
             -> Maybe ToolVersion
             -> Tool
             -> Excepts '[TagNotFound] m Version
@@ -611,6 +684,7 @@ printListResult lr = do
           , column expand left def def
           , column expand left def def
           , column expand left def def
+          , column expand left def def
           ]
         $ fmap
             (\ListResult {..} ->
@@ -621,6 +695,7 @@ printListResult lr = do
               , fmap toLower . show $ lTool
               , T.unpack . prettyVer $ lVer
               , intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag)
+              , if fromSrc then (color Blue "compiled") else mempty
               ]
             )
             lr

cabal.project

@@ -13,12 +13,3 @@ package ghcup
 package tar-bytestring
     ghc-options: -O2
 
-source-repository-package
-  type: git
-  location: https://github.com/composewell/streamly
-  tag: 4eb53e7f868bdc08afcc4b5210ab5916b9a4dfbc
-
-source-repository-package
-  type: git
-  location: https://github.com/hasufell/tar-bytestring
-  tag: 64707be1abb534e88007e3320090598a0a9490a7

cabal.project.freeze

@@ -1,5 +1,4 @@
 constraints: any.Cabal ==2.4.0.1,
-             any.HUnit ==1.6.0.0,
              any.HsOpenSSL ==0.11.4.17,
              HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -old-locale,
              any.IfElse ==0.85,
@@ -10,81 +9,97 @@ constraints: any.Cabal ==2.4.0.1,
              abstract-deque -usecas,
              any.aeson ==1.4.6.0,
              aeson -bytestring-builder -cffi -developer -fast,
+             any.aeson-pretty ==0.8.8,
+             aeson-pretty -lib-only,
              any.ansi-terminal ==0.10.3,
              ansi-terminal -example,
+             any.ansi-wl-pprint ==0.6.9,
+             ansi-wl-pprint -example,
              any.array ==0.5.3.0,
              any.ascii-string ==1.0.1.4,
+             any.assoc ==1.0.1,
              any.async ==2.2.2,
              async -bench,
              any.atomic-primops ==0.8.3,
              atomic-primops -debug,
              any.attoparsec ==0.13.2.3,
              attoparsec -developer,
+             any.auto-update ==0.1.6,
              any.base ==4.12.0.0,
              any.base-compat ==0.11.1,
              any.base-orphans ==0.8.2,
              any.base-prelude ==1.3,
+             any.base16-bytestring ==0.1.1.6,
              any.base64-bytestring ==1.0.0.3,
-             any.basement ==0.0.11,
              any.bifunctors ==5.5.7,
              bifunctors +semigroups +tagged,
              any.binary ==0.8.6.0,
              any.blaze-builder ==0.4.1.0,
+             any.brotli ==0.0.0.0,
+             any.brotli-streams ==0.0.0.0,
              any.bytestring ==0.10.8.2,
              any.bytestring-builder ==0.10.8.2.0,
              bytestring-builder +bytestring_has_builder,
              any.bzlib ==0.5.0.5,
              any.cabal-doctest ==1.0.8,
-             any.call-stack ==0.2.0,
              any.case-insensitive ==1.2.1.0,
              any.cereal ==0.5.8.1,
              cereal -bytestring-builder,
              any.clock ==0.8,
              clock -llvm,
+             any.cmdargs ==0.10.20,
+             cmdargs +quotation -testprog,
              any.colour ==2.3.5,
              any.comonad ==5.0.6,
              comonad +containers +distributive +test-doctests,
+             any.conduit ==1.3.1.2,
+             any.conduit-extra ==1.3.4,
              any.containers ==0.6.0.1,
              any.contravariant ==1.5.2,
              contravariant +semigroups +statevar +tagged,
              any.data-default-class ==0.1.2.0,
+             any.data-default-instances-base ==0.1.0.1,
              any.deepseq ==1.4.4.0,
              any.deferred-folds ==0.9.10.1,
-             any.directory ==1.3.3.0,
+             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.fusion-plugin ==0.1.1,
-             any.gauge ==0.2.5,
-             gauge +analysis,
+             any.free ==5.1.3,
+             any.fusion-plugin-types ==0.1.0,
              any.generics-sop ==0.5.0.0,
-             any.ghc ==8.6.5,
-             any.ghc-boot ==8.6.5,
              any.ghc-boot-th ==8.6.5,
-             any.ghc-heap ==8.6.5,
              any.ghc-prim ==0.5.3,
-             any.ghci ==8.6.5,
+             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.hpc ==0.6.0.3,
              any.hsc2hs ==0.68.6,
              hsc2hs -in-ghc-tree,
-             any.hspec ==2.7.1,
-             any.hspec-core ==2.7.1,
-             any.hspec-discover ==2.7.1,
-             any.hspec-expectations ==0.8.2,
-             any.http-io-streams ==0.1.0.0,
+             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,
@@ -92,6 +107,7 @@ constraints: any.Cabal ==2.4.0.1,
              any.io-streams ==1.5.1.0,
              io-streams -nointeractivetests,
              any.language-bash ==0.9.0,
+             any.lifted-base ==0.2.3.12,
              any.list-t ==1.0.4,
              any.lockfree-queue ==0.2.3.1,
              any.lzma ==0.0.0.3,
@@ -101,29 +117,42 @@ constraints: any.Cabal ==2.4.0.1,
              megaparsec -dev,
              any.mmorph ==1.1.3,
              any.monad-control ==1.0.2.3,
+             any.monad-logger ==0.3.32,
+             monad-logger +template_haskell,
+             any.monad-loops ==0.4.3,
+             monad-loops +base4,
+             any.mono-traversable ==1.0.15.1,
              any.mtl ==2.2.2,
              any.mwc-random ==0.14.0.0,
-             any.network ==3.0.1.1,
-             any.network-uri ==2.6.2.0,
+             any.network ==3.1.1.1,
+             any.network-uri ==2.6.3.0,
+             any.old-locale ==1.0.0.7,
+             any.old-time ==1.1.0.3,
              any.openssl-streams ==1.2.2.0,
              any.optics ==0.2,
              any.optics-core ==0.2,
              any.optics-extra ==0.2,
              any.optics-th ==0.2,
+             any.optics-vl ==0.2,
+             any.optparse-applicative ==0.15.1.0,
              any.parsec ==3.1.13.0,
              any.parser-combinators ==1.2.1,
              parser-combinators -dev,
              any.pretty ==1.1.3.6,
+             any.pretty-terminal ==0.1.0.0,
              any.prettyprinter ==1.6.1,
              prettyprinter -buildreadme,
-             any.primitive ==0.7.0.0,
+             any.primitive ==0.7.0.1,
              any.primitive-extras ==0.8,
              any.primitive-unlifted ==0.1.3.0,
-             any.process ==1.6.5.0,
+             any.process ==1.6.5.0 || ==1.6.8.0,
              any.profunctors ==5.5.2,
-             any.quickcheck-io ==0.2.0,
              any.random ==1.1,
+             any.recursion-schemes ==5.1.3,
+             recursion-schemes +template-haskell,
+             any.resourcet ==1.2.3,
              any.rts ==1.0,
+             any.safe ==0.3.18,
              any.safe-exceptions ==0.1.7.0,
              any.scientific ==0.3.6.2,
              scientific -bytestring-builder -integer-simple,
@@ -131,27 +160,42 @@ constraints: any.Cabal ==2.4.0.1,
              semigroupoids +comonad +containers +contravariant +distributive +doctests +tagged +unordered-containers,
              any.semigroups ==0.19.1,
              semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,
-             any.setenv ==0.1.1.3,
              any.sop-core ==0.5.0.0,
-             any.splitmix ==0.0.3,
+             any.split ==0.2.3.4,
+             any.splitmix ==0.0.4,
              splitmix -optimised-mixer +random,
              any.stm ==2.5.0.0,
+             any.stm-chans ==3.0.0.4,
+             any.streaming-commons ==0.2.1.2,
+             streaming-commons -use-bytestring-builder,
+             any.streamly ==0.7.1,
              streamly -debug -dev -examples -examples-sdl -fusion-plugin -has-llvm -inspection -no-charts -no-fusion -streamk,
              any.streamly-bytestring ==0.1.2,
+             any.streamly-posix ==0.1.0.0,
              any.strict-base ==0.4.0.0,
+             any.string-interpolate ==0.2.0.0,
              any.syb ==0.7.1,
+             any.table-layout ==0.8.0.5,
              any.tagged ==0.8.6,
              tagged +deepseq +transformers,
-             any.tar-bytestring ==0.6.2.0,
+             any.tar-bytestring ==0.6.3.0,
              any.template-haskell ==2.14.0.0,
-             any.terminfo ==0.4.1.2,
+             any.terminal-progress-bar ==0.4.1,
+             any.terminal-size ==0.3.2.1,
              any.text ==1.2.3.1,
+             any.text-conversions ==0.3.0,
              any.text-icu ==0.7.0.1,
              any.text-short ==0.1.3,
              text-short -asserts,
-             any.tf-random ==0.5,
              any.th-abstraction ==0.3.2.0,
-             any.time ==1.8.0.2,
+             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,
@@ -162,14 +206,20 @@ constraints: any.Cabal ==2.4.0.1,
              any.typed-process ==0.2.6.0,
              any.unix ==2.7.2.2,
              any.unix-bytestring ==0.3.7.3,
-             any.unliftio-core ==0.1.2.0,
+             any.unix-compat ==0.5.2,
+             unix-compat -old-time,
+             any.unix-time ==0.4.7,
+             any.unliftio-core ==0.2.0.1,
              any.unordered-containers ==0.2.10.0,
              unordered-containers -debug,
-             any.url ==2.1.3,
+             any.uri-bytestring ==0.3.2.2,
+             uri-bytestring -lib-werror,
              any.utf8-string ==1.0.1.1,
              any.uuid-types ==1.0.3,
              any.vector ==0.12.1.2,
              vector +boundschecks -internalchecks -unsafechecks -wall,
+             any.vector-algorithms ==0.8.0.3,
+             vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
              any.vector-builder ==0.3.8,
              any.vector-th-unbox ==0.2.1.7,
              any.versions ==3.5.3,

ghcup.cabal

@@ -27,8 +27,10 @@ common ascii-string { build-depends: ascii-string >= 1.0 }
 common async { build-depends: async >= 0.8 }
 common attoparsec { build-depends: attoparsec >= 0.13 }
 common base { build-depends: base >= 4.12 && < 5 }
+common binary { build-depends: binary >= 0.8.6.0 }
 common bytestring { build-depends: bytestring >= 0.10 }
 common bzlib { build-depends: bzlib >= 0.5.0.5 }
+common case-insensitive { build-depends: case-insensitive >= 1.2.1.0 }
 common containers { build-depends: containers >= 0.6 }
 common generics-sop { build-depends: generics-sop >= 0.5 }
 common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
@@ -39,7 +41,7 @@ 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 }
+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 }
@@ -53,16 +55,18 @@ common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 }
 common resourcet { build-depends: resourcet >= 1.2.2 }
 common safe { build-depends: safe >= 0.3.18 }
 common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
-common streamly { build-depends: streamly >= 0.7 }
+common streamly { build-depends: streamly >= 0.7.1 }
 common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 }
 common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
 common strict-base { build-depends: strict-base >= 0.4 }
 common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
 common table-layout { build-depends: table-layout >= 0.8 }
-common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 }
+common tar-bytestring { build-depends: tar-bytestring >= 0.6.3.0 }
 common template-haskell { build-depends: template-haskell >= 2.7 }
+common terminal-progress-bar { build-depends: terminal-progress-bar >= 0.4.1 }
 common text { build-depends: text >= 1.2 }
 common text-icu { build-depends: text-icu >= 0.7 }
+common time { build-depends: time >= 1.9.3 }
 common transformers { build-depends: transformers >= 0.5 }
 common unix { build-depends: unix >= 2.7 }
 common unix-bytestring { build-depends: unix-bytestring >= 0.3 }
@@ -96,8 +100,10 @@ library
                      , ascii-string
                      , async
                      , attoparsec
+                     , binary
                      , bytestring
                      , bzlib
+                     , case-insensitive
                      , containers
                      , generics-sop
                      , haskus-utils-types
@@ -128,8 +134,10 @@ library
                      , string-interpolate
                      , tar-bytestring
                      , template-haskell
+                     , terminal-progress-bar
                      , text
                      , text-icu
+                     , time
                      , transformers
                      , unix
                      , unix-bytestring
@@ -211,9 +219,7 @@ executable ghcup-gen
                        , uri-bytestring
                        , utf8-string
   main-is:             Main.hs
-  other-modules:       BinaryDownloads
-                       GHCupDownloads
-                       SourceDownloads
+  other-modules:       GHCupDownloads
                        Validate
   -- other-extensions:
   build-depends:       ghcup

lib/GHCup.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeApplications      #-}
 
--- TODO: handle SIGTERM, SIGUSR
 module GHCup where
 
 
@@ -23,6 +22,7 @@ import           GHCup.Utils.File
 import           GHCup.Utils.Prelude
 import           GHCup.Utils.String.QQ
 import           GHCup.Utils.Version.QQ
+import           GHCup.Version
 
 import           Control.Applicative
 import           Control.Exception.Safe
@@ -34,7 +34,6 @@ import           Control.Monad.Trans.Class      ( lift )
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
 import           Data.ByteString                ( ByteString )
-import           Data.Foldable
 import           Data.List
 import           Data.Maybe
 import           Data.String.Interpolate
@@ -50,7 +49,6 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           System.IO.Error
-import           System.Posix.Env.ByteString    ( getEnvironment )
 import           System.Posix.FilePath          ( getSearchPath )
 import           System.Posix.RawFilePath.Directory.Errors
                                                 ( hideError )
@@ -65,55 +63,116 @@ import qualified Data.Text.Encoding            as E
     --[ Tool installation ]--
     -------------------------
 
--- TODO: custom logger intepreter and pretty printing
 
--- | Install a tool, such as GHC or cabal. This also sets
--- the ghc-x.y.z symlinks and potentially the ghc-x.y.
---
--- This can fail in many ways. You may want to explicitly catch
--- `AlreadyInstalled` to not make it fatal.
-installTool :: ( MonadThrow m
-               , MonadReader Settings m
-               , MonadLogger m
-               , MonadCatch m
-               , MonadIO m
-               , MonadFail m
-               , MonadResource m
-               ) -- tmp file
-            => BinaryDownloads
-            -> ToolRequest
-            -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-            -> Excepts
-                 '[ AlreadyInstalled
-                  , ArchiveError
-                  , DistroNotFound
-                  , FileDoesNotExistError
-                  , FileError
-                  , JSONError
-                  , NoCompatibleArch
-                  , NoDownload
-                  , NotInstalled
-                  , PlatformResultError
-                  , ProcessError
-                  , URLException
-                  , DigestError
-                  ]
-                 m
-                 ()
-installTool bDls treq mpfReq = do
-  lift $ $(logDebug) [i|Requested to install: #{treq}|]
-
-  -- stop if GHC is already installed, other tools can be overwritten
-  case treq of
-    (ToolRequest GHC _) ->
-      whenM (liftIO $ toolAlreadyInstalled treq)
-        $ (throwE $ AlreadyInstalled treq)
-    (ToolRequest Cabal _) -> pure ()
 
+installGHCBin :: ( MonadFail m
+                 , MonadMask m
+                 , MonadCatch m
+                 , MonadReader Settings m
+                 , MonadLogger m
+                 , MonadResource m
+                 , MonadIO m
+                 )
+              => GHCupDownloads
+              -> Version
+              -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
+              -> Excepts
+                   '[ AlreadyInstalled
+                    , BuildFailed
+                    , DigestError
+                    , DistroNotFound
+                    , DownloadFailed
+                    , NoCompatibleArch
+                    , NoCompatiblePlatform
+                    , NoDownload
+                    , NotInstalled
+                    , UnknownArchive
+                    ]
+                   m
+                   ()
+installGHCBin bDls ver mpfReq = do
+  lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
+  whenM (liftIO $ toolAlreadyInstalled GHC ver)
+    $ (throwE $ AlreadyInstalled GHC ver)
   Settings {..} <- lift ask
 
   -- download (or use cached version)
-  dlinfo        <- liftE $ getDownloadInfo bDls treq mpfReq
+  dlinfo        <- liftE $ getDownloadInfo bDls GHC ver mpfReq
+  dl            <- liftE $ downloadCached dlinfo Nothing
+
+  -- unpack
+  tmpUnpack     <- lift mkGhcupTmpDir
+  liftE $ unpackToDir tmpUnpack dl
+
+  -- prepare paths
+  ghcdir <- liftIO $ ghcupGHCDir ver
+
+  -- the subdir of the archive where we do the work
+  let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
+
+  catchAllE
+      (\es ->
+        liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
+          >> throwE (BuildFailed archiveSubdir es)
+      )
+    $ installGHC' archiveSubdir ghcdir
+
+  -- only clean up dir if the build succeeded
+  liftIO $ deleteDirRecursive tmpUnpack
+
+  liftE $ postGHCInstall ver
+
+ where
+    -- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
+  installGHC' :: (MonadLogger m, MonadIO m)
+              => Path Abs      -- ^ Path to the unpacked GHC bindist (where the configure script resides)
+              -> Path Abs      -- ^ Path to install to
+              -> Excepts '[ProcessError] m ()
+  installGHC' path inst = do
+    lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
+    lEM $ liftIO $ execLogged [s|./configure|]
+                              False
+                              [[s|--prefix=|] <> toFilePath inst]
+                              ([rel|ghc-configure.log|] :: Path Rel)
+                              (Just path)
+                              Nothing
+    lEM $ liftIO $ execLogged [s|make|]
+                              True
+                              [[s|install|]]
+                              ([rel|ghc-make.log|] :: Path Rel)
+                              (Just path)
+                              Nothing
+    pure ()
+
+
+installCabalBin :: ( MonadMask m
+                   , MonadCatch m
+                   , MonadReader Settings m
+                   , MonadLogger m
+                   , MonadResource m
+                   , MonadIO m
+                   )
+                => GHCupDownloads
+                -> Version
+                -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
+                -> Excepts
+                     '[ CopyError
+                      , DigestError
+                      , DistroNotFound
+                      , DownloadFailed
+                      , NoCompatibleArch
+                      , NoCompatiblePlatform
+                      , NoDownload
+                      , UnknownArchive
+                      ]
+                     m
+                     ()
+installCabalBin bDls ver mpfReq = do
+  lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
+  Settings {..} <- lift ask
+
+  -- download (or use cached version)
+  dlinfo        <- liftE $ getDownloadInfo bDls Cabal ver mpfReq
   dl            <- liftE $ downloadCached dlinfo Nothing
 
   -- unpack
@@ -121,62 +180,28 @@ installTool bDls treq mpfReq = do
   liftE $ unpackToDir tmpUnpack dl
 
   -- prepare paths
-  ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq)
   bindir <- liftIO ghcupBinDir
 
   -- the subdir of the archive where we do the work
   let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
 
-  case treq of
-    (ToolRequest GHC ver) -> do
-      liftE $ installGHC archiveSubdir ghcdir
-      liftE $ postGHCInstall ver
-    (ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir
+  liftE $ installCabal' archiveSubdir bindir
   pure ()
 
-
-toolAlreadyInstalled :: ToolRequest -> IO Bool
-toolAlreadyInstalled ToolRequest {..} = case _trTool of
-  GHC   -> ghcInstalled _trVersion
-  Cabal -> cabalInstalled _trVersion
-
-
-
--- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
-installGHC :: (MonadLogger m, MonadIO m)
-           => Path Abs      -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-           -> Path Abs      -- ^ Path to install to
-           -> Excepts '[ProcessError] m ()
-installGHC path inst = do
-  lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
-  lEM $ liftIO $ execLogged [s|./configure|]
-                            False
-                            [[s|--prefix=|] <> toFilePath inst]
-                            ([rel|ghc-configure.log|] :: Path Rel)
-                            (Just path)
-                            Nothing
-  lEM $ liftIO $ execLogged [s|make|]
-                            True
-                            [[s|install|]]
-                            ([rel|ghc-make.log|] :: Path Rel)
-                            (Just path)
-                            Nothing
-  pure ()
-
-
--- | Install an unpacked cabal distribution.
-installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
-             => Path Abs      -- ^ Path to the unpacked cabal bindist (where the executable resides)
-             -> Path Abs      -- ^ Path to install to
-             -> Excepts '[FileError] m ()
-installCabal path inst = do
-  lift $ $(logInfo) [s|Installing cabal|]
-  let cabalFile = [rel|cabal|] :: Path Rel
-  liftIO $ createDirIfMissing newDirPerms inst
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
-    (path </> cabalFile)
-    (inst </> cabalFile)
-    Overwrite
+ where
+    -- | Install an unpacked cabal distribution.
+  installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
+                => Path Abs      -- ^ Path to the unpacked cabal bindist (where the executable resides)
+                -> Path Abs      -- ^ Path to install to
+                -> Excepts '[CopyError] m ()
+  installCabal' path inst = do
+    lift $ $(logInfo) [s|Installing cabal|]
+    let cabalFile = [rel|cabal|] :: Path Rel
+    liftIO $ createDirIfMissing newDirPerms inst
+    handleIO (throwE . CopyError . show) $ liftIO $ copyFile
+      (path </> cabalFile)
+      (inst </> cabalFile)
+      Overwrite
 
 
 
@@ -190,12 +215,12 @@ installCabal path inst = do
 -- on `SetGHC`:
 --
 --   * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
---   * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
---   * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
+--   * SetGHC_XY: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
+--   * SetGHC_XYZ: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
 --
 -- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
 -- for `SetGHCOnly` constructor.
-setGHC :: (MonadThrow m, MonadFail m, MonadIO m)
+setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
        => Version
        -> SetGHC
        -> Excepts '[NotInstalled] m ()
@@ -207,59 +232,58 @@ setGHC ver sghc = do
   bindir <- liftIO $ ghcupBinDir
   liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
 
-  when (sghc == SetGHCOnly) $ liftE (delOldSymlinks bindir)
+  -- first delete the old symlinks (this fixes compatibility issues
+  -- with old ghcup)
+  case sghc of
+    SetGHCOnly -> liftE $ rmPlain ver
+    SetGHC_XY  -> lift $ rmMajorSymlinks ver
+    SetGHC_XYZ -> lift $ rmMinorSymlinks ver
 
   -- for ghc tools (ghc, ghci, haddock, ...)
   verfiles <- ghcToolFiles ver
   forM_ verfiles $ \file -> do
     liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> file)
     targetFile <- case sghc of
-      SetGHCOnly  -> pure file
-      SetGHCMajor -> do
+      SetGHCOnly -> pure file
+      SetGHC_XY  -> do
         major' <-
           (\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
             <$> getGHCMajor ver
         parseRel (toFilePath file <> B.singleton _hyphen <> major')
-      SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
-    liftIO $ hideError doesNotExistErrorType $ deleteFile
-      (bindir </> targetFile)
-    liftIO $ createSymlink (bindir </> targetFile)
-                           (ghcLinkDestination (toFilePath file) ver)
+      SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
+
+    -- create symlink
+    let fullF = bindir </> targetFile
+    let destL = ghcLinkDestination (toFilePath file) ver
+    lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
+    liftIO $ createSymlink fullF destL
 
   -- create symlink for share dir
-  liftIO $ symlinkShareDir ghcdir verBS
+  lift $ symlinkShareDir ghcdir verBS
 
   pure ()
 
  where
 
-  symlinkShareDir :: Path Abs -> ByteString -> IO ()
+  symlinkShareDir :: (MonadIO m, MonadLogger m)
+                  => Path Abs
+                  -> ByteString
+                  -> m ()
   symlinkShareDir ghcdir verBS = do
-    destdir <- ghcupBaseDir
+    destdir <- liftIO $ ghcupBaseDir
     case sghc of
       SetGHCOnly -> do
         let sharedir     = [rel|share|] :: Path Rel
         let fullsharedir = ghcdir </> sharedir
-        whenM (doesDirectoryExist fullsharedir) $ do
-          liftIO $ hideError doesNotExistErrorType $ deleteFile
-            (destdir </> sharedir)
-          createSymlink
-            (destdir </> sharedir)
-            ([s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
+        whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
+          let fullF   = destdir </> sharedir
+          let targetF = [s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir
+          $(logDebug) [i|rm -f #{fullF}|]
+          liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
+          $(logDebug) [i|ln -s #{targetF} #{fullF}|]
+          liftIO $ createSymlink fullF targetF
       _ -> pure ()
 
-  -- The old tool symlinks might be different (e.g. more) than the
-  -- requested version. Have to avoid "stray" symlinks.
-  delOldSymlinks :: forall m
-                  . (MonadThrow m, MonadFail m, MonadIO m)
-                 => Path Abs
-                 -> Excepts '[] m ()
-  delOldSymlinks bindir = catchLiftLeft (\NotInstalled{} -> pure ()) $ do
-    mv <- ghcSet
-    for_ mv $ \ver' -> do
-      verfiles <- ghcToolFiles ver'
-      for_ verfiles $ \f -> liftIO $ deleteFile (bindir </> f)
-
 
 
 
@@ -278,17 +302,18 @@ data ListResult = ListResult
   , lTag       :: [Tag]
   , lInstalled :: Bool
   , lSet       :: Bool
+  , fromSrc    :: Bool
   }
   deriving Show
 
 
-availableToolVersions :: BinaryDownloads -> Tool -> [(Version, [Tag])]
+availableToolVersions :: GHCupDownloads -> Tool -> [(Version, [Tag])]
 availableToolVersions av tool = toListOf
   (ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
   av
 
 
-listVersions :: BinaryDownloads
+listVersions :: GHCupDownloads
              -> Maybe Tool
              -> Maybe ListCriteria
              -> IO [ListResult]
@@ -298,7 +323,8 @@ listVersions av lt criteria = case lt of
   Nothing -> do
     ghcvers   <- listVersions av (Just GHC) criteria
     cabalvers <- listVersions av (Just Cabal) criteria
-    pure (ghcvers <> cabalvers)
+    ghcupvers <- listVersions av (Just GHCup) criteria
+    pure (ghcvers <> cabalvers <> ghcupvers)
 
  where
   toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
@@ -306,11 +332,17 @@ listVersions av lt criteria = case lt of
     GHC -> do
       lSet       <- fmap (maybe False (== v)) $ ghcSet
       lInstalled <- ghcInstalled v
+      fromSrc    <- ghcSrcInstalled v
       pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
     Cabal -> do
       lSet       <- fmap (== v) $ cabalSet
       lInstalled <- cabalInstalled v
-      pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
+      pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
+    GHCup -> do
+      let lSet       = prettyPVP ghcUpVer == prettyVer v
+      let lInstalled = True
+      pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
+
 
   filter' :: [ListResult] -> [ListResult]
   filter' lr = case criteria of
@@ -320,8 +352,6 @@ listVersions av lt criteria = case lt of
 
 
 
-
-
     --------------
     --[ GHC rm ]--
     --------------
@@ -335,9 +365,8 @@ rmGHCVer ver = do
   isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
   dir      <- liftIO $ ghcupGHCDir ver
   let d' = toFilePath dir
-  exists     <- liftIO $ doesDirectoryExist dir
+  exists <- liftIO $ doesDirectoryExist dir
 
-  toolsFiles <- liftE $ ghcToolFiles ver
 
   if exists
     then do
@@ -346,59 +375,27 @@ rmGHCVer ver = do
       liftIO $ deleteDirRecursive dir
 
       lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
-      liftIO $ rmMinorSymlinks
+      lift $ rmMinorSymlinks ver
 
       lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
-      liftE fixMajorSymlinks
+      -- first remove
+      lift $ rmMajorSymlinks ver
+      -- then fix them (e.g. with an earlier version)
+      (mj, mi) <- getGHCMajor ver
+      getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
 
-      when isSetGHC $ liftE $ do
+
+      when isSetGHC $ do
         lift $ $(logInfo) [i|Removing ghc symlinks|]
-        rmPlain toolsFiles
+        liftE $ rmPlain ver
 
       liftIO
         $   ghcupBaseDir
         >>= hideError doesNotExistErrorType
         .   deleteFile
         .   (</> ([rel|share|] :: Path Rel))
-    else throwE (NotInstalled $ ToolRequest GHC ver)
+    else throwE (NotInstalled GHC ver)
 
- where
-  -- e.g. ghc-8.6.5
-  rmMinorSymlinks :: IO ()
-  rmMinorSymlinks = do
-    bindir <- ghcupBinDir
-    files  <- getDirsFiles' bindir
-    let myfiles = filter
-          (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x)
-          files
-    forM_ myfiles $ \f -> deleteFile (bindir </> f)
-
-  -- E.g. ghc, if this version is the set one.
-  -- This reads `ghcupGHCDir`.
-  rmPlain :: (MonadThrow m, MonadFail m, MonadIO m)
-          => [Path Rel] -- ^ tools files
-          -> Excepts '[NotInstalled] m ()
-  rmPlain files = do
-    bindir <- liftIO $ ghcupBinDir
-    forM_ files $ \f -> liftIO $ deleteFile (bindir </> f)
-
-  -- e.g. ghc-8.6
-  fixMajorSymlinks :: (MonadFail m, MonadThrow m, MonadIO m)
-                   => Excepts '[NotInstalled] m ()
-  fixMajorSymlinks = do
-    (mj, mi) <- getGHCMajor ver
-    let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
-
-    bindir <- liftIO $ ghcupBinDir
-
-    -- first delete them
-    files  <- liftIO $ getDirsFiles' bindir
-    let myfiles =
-          filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
-    forM_ myfiles $ \f -> liftIO $ deleteFile (bindir </> f)
-
-    -- then fix them (e.g. with an earlier version)
-    getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
 
 
 
@@ -409,7 +406,7 @@ rmGHCVer ver = do
 
 getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
              => Excepts
-                  '[PlatformResultError , NoCompatibleArch , DistroNotFound]
+                  '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
                   m
                   DebugInfo
 getDebugInfo = do
@@ -430,38 +427,37 @@ getDebugInfo = do
     ---------------
 
 
-compileGHC :: ( MonadReader Settings m
+compileGHC :: ( MonadMask m
+              , MonadReader Settings m
               , MonadThrow m
               , MonadResource m
               , MonadLogger m
               , MonadIO m
               , MonadFail m
               )
-           => SourceDownloads
+           => GHCupDownloads
            -> Version          -- ^ version to install
            -> Version          -- ^ version to bootstrap with
            -> Maybe Int        -- ^ jobs
            -> Maybe (Path Abs) -- ^ build config
            -> Excepts
                 '[ AlreadyInstalled
-                 , NotInstalled
-                 , GHCNotFound
-                 , ArchiveError
-                 , ProcessError
-                 , URLException
+                 , BuildFailed
                  , DigestError
-                 , BuildConfigNotFound
+                 , DownloadFailed
+                 , GHCupSetError
+                 , NoDownload
+                 , UnknownArchive
                  ]
                 m
                 ()
 compileGHC dls tver bver jobs mbuildConfig = do
-  let treq = ToolRequest GHC tver
   lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
-  alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
-  when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
+  whenM (liftIO $ toolAlreadyInstalled GHC tver)
+        (throwE $ AlreadyInstalled GHC tver)
 
   -- download source tarball
-  dlInfo    <- preview (ix tver) dls ?? GHCNotFound
+  dlInfo    <- preview (ix GHC % ix tver % viSourceDL % _Just) dls ?? NoDownload
   dl        <- liftE $ downloadCached dlInfo Nothing
 
   -- unpack
@@ -470,43 +466,20 @@ compileGHC dls tver bver jobs mbuildConfig = do
 
   bghc <- parseRel ([s|ghc-|] <> verToBS bver)
   let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
-
   ghcdir <- liftIO $ ghcupGHCDir tver
-  if
-    | tver >= [vver|8.8.0|] -> do
-      cEnv     <- liftIO $ getEnvironment
-      spaths   <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
-      bghcPath <- (liftIO $ searchPath spaths bghc) !? GHCNotFound
-      let newEnv = ([s|GHC|], toFilePath bghcPath) : cEnv
-      lEM $ liftIO $ exec [s|./configure|]
-                          False
-                          [[s|--prefix=|] <> toFilePath ghcdir]
-                          (Just workdir)
-                          (Just newEnv)
-    | otherwise -> do
-      lEM $ liftIO $ exec
-        [s|./configure|]
-        False
-        [ [s|--prefix=|] <> toFilePath ghcdir
-        , [s|--with-ghc=|] <> toFilePath bghc
-        ]
-        (Just workdir)
-        Nothing
 
-  let build_mk = workdir </> ([rel|mk/build.mk|] :: Path Rel)
-  case mbuildConfig of
-    Just bc -> liftIO $ copyFile bc build_mk Overwrite
-    Nothing -> liftIO $ writeFile build_mk (Just newFilePerms) defaultConf
+  catchAllE
+      (\es ->
+        liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
+          >> throwE (BuildFailed workdir es)
+      )
+    $ compile bghc ghcdir workdir
+  markSrcBuilt ghcdir workdir
 
-  lEM $ liftIO $ exec [s|make|]
-                      True
-                      (maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
-                      (Just workdir)
-                      Nothing
+  -- only clean up dir if the build succeeded
+  liftIO $ deleteDirRecursive tmpUnpack
 
-  lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just workdir) Nothing
-
-  liftE $ postGHCInstall tver
+  reThrowAll GHCupSetError $ postGHCInstall tver
   pure ()
 
  where
@@ -518,28 +491,160 @@ BUILD_SPHINX_PDF = NO
 HADDOCK_DOCS = YES
 GhcWithLlvmCodeGen = YES|]
 
+  compile :: (MonadCatch m, MonadLogger m, MonadIO m)
+          => Path Rel
+          -> Path Abs
+          -> Path Abs
+          -> Excepts
+               '[NoDownload , FileDoesNotExistError , ProcessError]
+               m
+               ()
+  compile bghc ghcdir workdir = do
+    lift $ $(logInfo) [i|configuring build|]
+    if
+      | tver >= [vver|8.8.0|] -> do
+        spaths   <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
+        bghcPath <- (liftIO $ searchPath spaths bghc) !? NoDownload
+        newEnv   <- addToCurrentEnv [([s|GHC|], toFilePath bghcPath)]
+        lEM $ liftIO $ execLogged [s|./configure|]
+                                  False
+                                  [[s|--prefix=|] <> toFilePath ghcdir]
+                                  ([rel|ghc-configure.log|] :: Path Rel)
+                                  (Just workdir)
+                                  (Just newEnv)
+      | otherwise -> do
+        lEM $ liftIO $ execLogged
+          [s|./configure|]
+          False
+          [ [s|--prefix=|] <> toFilePath ghcdir
+          , [s|--with-ghc=|] <> toFilePath bghc
+          ]
+          ([rel|ghc-configure.log|] :: Path Rel)
+          (Just workdir)
+          Nothing
+
+    case mbuildConfig of
+      Just bc -> liftIOException
+        doesNotExistErrorType
+        (FileDoesNotExistError $ toFilePath bc)
+        (liftIO $ copyFile bc (build_mk workdir) Overwrite)
+      Nothing ->
+        liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
+
+    lift
+      $ $(logInfo)
+          [i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/ghc-make.log' to see the progress.|]
+    lEM $ liftIO $ execLogged [s|make|]
+                              True
+                              (maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
+                              ([rel|ghc-make.log|] :: Path Rel)
+                              (Just workdir)
+                              Nothing
+
+    lift $ $(logInfo) [i|Installing...|]
+    lEM $ liftIO $ execLogged [s|make|]
+                              True
+                              [[s|install|]]
+                              ([rel|ghc-make.log|] :: Path Rel)
+                              (Just workdir)
+                              Nothing
+
+  markSrcBuilt ghcdir workdir = do
+    let dest = (ghcdir </> ghcUpSrcBuiltFile)
+    liftIO $ copyFile (build_mk workdir) dest Overwrite
+
+  build_mk workdir = workdir </> ([rel|mk/build.mk|] :: Path Rel)
 
 
-    ---------------
-    --[ Set GHC ]--
-    ---------------
+compileCabal :: ( MonadReader Settings m
+                , MonadResource m
+                , MonadMask m
+                , MonadLogger m
+                , MonadIO m
+                )
+             => GHCupDownloads
+             -> Version          -- ^ version to install
+             -> Version          -- ^ GHC version to build with
+             -> Maybe Int
+             -> Excepts
+                  '[ BuildFailed
+                   , DigestError
+                   , DownloadFailed
+                   , NoDownload
+                   , UnknownArchive
+                   ]
+                  m
+                  ()
+compileCabal dls tver bver jobs = do
+  lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bver}|]
+
+  -- download source tarball
+  dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
+  dl <- liftE $ downloadCached dlInfo Nothing
+
+  -- unpack
+  tmpUnpack <- lift mkGhcupTmpDir
+  liftE $ unpackToDir tmpUnpack dl
+
+  let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
+
+  reThrowAll (BuildFailed workdir) $ compile workdir
+
+  -- only clean up dir if the build succeeded
+  liftIO $ deleteDirRecursive tmpUnpack
+
+  pure ()
+
+ where
+  compile :: (MonadLogger m, MonadIO m)
+          => Path Abs
+          -> Excepts '[ProcessError] m ()
+  compile workdir = do
+    lift
+      $ $(logInfo)
+          [i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/cabal-bootstrap.log' to see the progress.|]
+
+    let v' = verToBS bver
+    cabal_bin <- liftIO $ ghcupBinDir
+    newEnv    <- lift $ addToCurrentEnv
+      [ ([s|GHC|]    , [s|ghc-|] <> v')
+      , ([s|GHC_PKG|], [s|ghc-pkg-|] <> v')
+      , ([s|GHC_VER|], v')
+      , ([s|PREFIX|] , toFilePath cabal_bin)
+      ]
+
+    lEM $ liftIO $ execLogged [s|./bootstrap.sh|]
+                              False
+                              (maybe [] (\j -> [[s|-j|], fS (show j)]) jobs)
+                              ([rel|cabal-bootstrap.log|] :: Path Rel)
+                              (Just workdir)
+                              (Just newEnv)
 
 
-upgradeGHCup :: ( MonadReader Settings m
+
+
+    ---------------------
+    --[ Upgrade GHCup ]--
+    ---------------------
+
+
+upgradeGHCup :: ( MonadMask m
+                , MonadReader Settings m
                 , MonadCatch m
                 , MonadLogger m
                 , MonadThrow m
                 , MonadResource m
                 , MonadIO m
                 )
-             => BinaryDownloads
+             => GHCupDownloads
              -> Maybe (Path Abs)  -- ^ full file destination to write ghcup into
              -> Excepts
-                  '[ DigestError
-                   , URLException
+                  '[ CopyError
+                   , DigestError
                    , DistroNotFound
-                   , PlatformResultError
+                   , DownloadFailed
                    , NoCompatibleArch
+                   , NoCompatiblePlatform
                    , NoDownload
                    ]
                   m
@@ -547,14 +652,16 @@ upgradeGHCup :: ( MonadReader Settings m
 upgradeGHCup dls mtarget = do
   lift $ $(logInfo) [i|Upgrading GHCup...|]
   let latestVer = head $ getTagged dls GHCup Latest
-  dli <- liftE $ getDownloadInfo dls (ToolRequest GHCup latestVer) Nothing
+  dli <- liftE $ getDownloadInfo dls GHCup latestVer Nothing
   tmp <- lift withGHCupTmpDir
   let fn = [rel|ghcup|] :: Path Rel
   p <- liftE $ download dli tmp (Just fn)
   case mtarget of
     Nothing -> do
       dest <- liftIO $ ghcupBinDir
-      liftIO $ copyFile p (dest </> fn) Overwrite
+      handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
+                                                               (dest </> fn)
+                                                               Overwrite
     Just fullDest -> liftIO $ copyFile p fullDest Overwrite
   pure latestVer
 
@@ -565,14 +672,15 @@ upgradeGHCup dls mtarget = do
     -------------
 
 
--- | Creates ghc-x.y.z and ghc-x.y symlinks.
-postGHCInstall :: (MonadThrow m, MonadFail m, MonadIO m)
+-- | Creates ghc-x.y.z and ghc-x.y symlinks. This is used for
+-- both installing from source and bindist.
+postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
                => Version
                -> Excepts '[NotInstalled] m ()
 postGHCInstall ver = do
-  liftE $ setGHC ver SetGHCMinor
+  liftE $ setGHC ver SetGHC_XYZ
 
   -- Create ghc-x.y symlinks. This may not be the current
   -- version, create it regardless.
   (mj, mi) <- liftIO $ getGHCMajor ver
-  getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
+  getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)

lib/GHCup/Download.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE QuasiQuotes           #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeApplications      #-}
 
 
 module GHCup.Download where
@@ -22,6 +23,7 @@ import           GHCup.Utils.String.QQ
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
+import           Control.Monad.Fail             ( MonadFail )
 import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Class      ( lift )
@@ -30,9 +32,14 @@ import           Control.Monad.Trans.Resource
 import           Data.Aeson
 import           Data.ByteString                ( ByteString )
 import           Data.ByteString.Builder
+import           Data.CaseInsensitive           ( CI )
 import           Data.IORef
 import           Data.Maybe
 import           Data.String.Interpolate
+import           Data.Text.Read
+import           Data.Time.Clock
+import           Data.Time.Clock.POSIX
+import           Data.Time.Format
 import           Data.Versions
 import           GHC.IO.Exception
 import           HPath
@@ -52,24 +59,35 @@ 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://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
+ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
 
 
 
--- | Downloads the download information!
+    ------------------
+    --[ High-level ]--
+    ------------------
+
+
+-- | Downloads the download information! But only if we need to ;P
 getDownloads :: ( FromJSONKey Tool
                 , FromJSONKey Version
                 , FromJSON VersionInfo
@@ -77,23 +95,113 @@ getDownloads :: ( FromJSONKey Tool
                 , MonadCatch m
                 , MonadReader Settings m
                 , MonadLogger m
+                , MonadThrow m
+                , MonadFail m
                 )
-             => Excepts
-                  '[FileDoesNotExistError , URLException , JSONError]
-                  m
-                  GHCupDownloads
+             => Excepts '[JSONError , DownloadFailed] m GHCupDownloads
 getDownloads = do
   urlSource <- lift getUrlSource
   lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
   case urlSource of
     GHCupURL -> do
-      bs <- liftE $ downloadBS ghcupURL
+      bs <- reThrowAll DownloadFailed $ dl ghcupURL
       lE' JSONDecodeError $ eitherDecode' bs
     (OwnSource url) -> do
-      bs <- liftE $ downloadBS url
+      bs <- reThrowAll DownloadFailed $ dl url
       lE' JSONDecodeError $ eitherDecode' bs
     (OwnSpec av) -> pure $ av
 
+ where
+  -- First check if the json file is in the ~/.ghcup/cache dir
+  -- and check it's access time. If it has been accessed within the
+  -- last 5 minutes, just reuse it.
+  --
+  -- If not, then send a HEAD request and check for modification time.
+  -- Only download the file if the modification time is newer
+  -- than the local file.
+  --
+  -- Always save the local file with the mod time of the remote file.
+  dl :: forall m1
+      . (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
+     => URI
+     -> Excepts
+          '[ FileDoesNotExistError
+           , HTTPStatusError
+           , URIParseError
+           , UnsupportedScheme
+           , NoLocationHeader
+           , TooManyRedirs
+           ]
+          m1
+          L.ByteString
+  dl uri' = do
+    let path = view pathL' uri'
+    json_file <- (liftIO $ ghcupCacheDir)
+      >>= \cacheDir -> (cacheDir </>) <$> urlBaseName path
+    e <- liftIO $ doesFileExist json_file
+    if e
+      then do
+        accessTime <-
+          PF.accessTimeHiRes
+            <$> (liftIO $ PF.getFileStatus (toFilePath json_file))
+        currentTime <- liftIO $ getPOSIXTime
+
+        -- access time won't work on most linuxes, but we can try regardless
+        if (currentTime - accessTime) > 300
+          then do -- no access in last 5 minutes, re-check upstream mod time
+            getModTime >>= \case
+              Just modTime -> do
+                fileMod <- liftIO $ getModificationTime json_file
+                if modTime > fileMod
+                  then do
+                    bs <- liftE $ downloadBS uri'
+                    liftIO $ writeFileWithModTime modTime json_file bs
+                    pure bs
+                  else liftIO $ readFile json_file
+              Nothing -> do
+                lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
+                liftIO $ deleteFile json_file
+                liftE $ downloadBS uri'
+          else -- access in less than 5 minutes, re-use file
+               liftIO $ readFile json_file
+      else do
+        getModTime >>= \case
+          Just modTime -> do
+            bs <- liftE $ downloadBS uri'
+            liftIO $ writeFileWithModTime modTime json_file bs
+            pure bs
+          Nothing -> do
+            lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
+            liftE $ downloadBS uri'
+
+   where
+    getModTime = do
+      headers <-
+        handleIO (\_ -> pure mempty)
+        $ liftE
+        $ ( catchAllE
+              (\_ ->
+                pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
+              )
+          $ getHead uri'
+          )
+      pure $ parseModifiedHeader headers
+
+
+  parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
+  parseModifiedHeader headers =
+    (M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM
+      True
+      defaultTimeLocale
+      "%a, %d %b %Y %H:%M:%S %Z"
+      (T.unpack . E.decodeUtf8 $ h)
+
+  writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
+  writeFileWithModTime utctime path content = do
+    let mod_time = utcTimeToPOSIXSeconds utctime
+    writeFileL path (Just newFilePerms) content
+    setModificationTimeHiRes path mod_time
+
 
 
 getDownloadInfo :: ( MonadLogger m
@@ -101,18 +209,19 @@ getDownloadInfo :: ( MonadLogger m
                    , MonadIO m
                    , MonadReader Settings m
                    )
-                => BinaryDownloads
-                -> ToolRequest
+                => GHCupDownloads
+                -> Tool
+                -> Version
                 -> Maybe PlatformRequest
                 -> Excepts
                      '[ DistroNotFound
-                      , PlatformResultError
+                      , NoCompatiblePlatform
                       , NoCompatibleArch
                       , NoDownload
                       ]
                      m
                      DownloadInfo
-getDownloadInfo bDls (ToolRequest t v) mpfReq = do
+getDownloadInfo bDls t v mpfReq = do
   (PlatformRequest arch' plat ver) <- case mpfReq of
     Just x  -> pure x
     Nothing -> do
@@ -132,7 +241,7 @@ getDownloadInfo' :: Tool
                 -- ^ user platform
                  -> Maybe Versioning
                 -- ^ optional version of the platform
-                 -> BinaryDownloads
+                 -> GHCupDownloads
                  -> Either NoDownload DownloadInfo
 getDownloadInfo' t v a p mv dls = maybe
   (Left NoDownload)
@@ -155,15 +264,21 @@ getDownloadInfo' t v a p mv dls = maybe
 --   2. otherwise create a random file
 --
 -- The file must not exist.
-download :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
+download :: ( MonadMask m
+            , MonadReader Settings m
+            , MonadThrow m
+            , MonadLogger m
+            , MonadIO m
+            )
          => DownloadInfo
          -> Path Abs          -- ^ destination dir
          -> Maybe (Path Rel)  -- ^ optional filename
-         -> Excepts '[DigestError , URLException] m (Path Abs)
-download dli dest mfn | scheme == [s|https|] = dl True
-                      | scheme == [s|http|] = dl False
-                      | scheme == [s|file|] = cp
-                      | otherwise           = throwE UnsupportedURL
+         -> Excepts '[DigestError , DownloadFailed] m (Path Abs)
+download dli dest mfn
+  | scheme == [s|https|] = dl
+  | scheme == [s|http|] = dl
+  | scheme == [s|file|] = cp
+  | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
 
  where
   scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
@@ -174,16 +289,12 @@ download dli dest mfn | scheme == [s|https|] = dl True
     fromFile <- parseAbs path
     liftIO $ copyFile fromFile destFile Strict
     pure destFile
-  dl https = do
+  dl = do
     let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
     lift $ $(logInfo) [i|downloading: #{uri'}|]
 
-    host <-
-      preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
-        ?? UnsupportedURL
-    let port = preview
-          (dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
-          dli
+    (https, host, fullPath, port) <- reThrowAll DownloadFailed
+      $ uriToQuadruple (view dlUri dli)
 
     -- destination dir must exist
     liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
@@ -192,13 +303,10 @@ download dli dest mfn | scheme == [s|https|] = dl True
     -- download
     fd       <- liftIO $ createRegularFileFd newFilePerms destFile
     let stepper = fdWrite fd
-    liftIO $ flip finally (closeFd fd) $ downloadInternal https
-                                                          host
-                                                          path
-                                                          port
-                                                          stepper
+    flip finally (liftIO $ closeFd fd)
+      $ reThrowAll DownloadFailed
+      $ downloadInternal True https host fullPath port stepper
 
-    -- TODO: verify md5 during download
     liftE $ checkDigest dli destFile
     pure destFile
 
@@ -211,7 +319,8 @@ download dli dest mfn | scheme == [s|https|] = dl True
 
 -- | Download into tmpdir or use cached version, if it exists. If filename
 -- is omitted, infers the filename from the url.
-downloadCached :: ( MonadResource m
+downloadCached :: ( MonadMask m
+                  , MonadResource m
                   , MonadThrow m
                   , MonadLogger m
                   , MonadIO m
@@ -219,7 +328,7 @@ downloadCached :: ( MonadResource m
                   )
                => DownloadInfo
                -> Maybe (Path Rel)  -- ^ optional filename
-               -> Excepts '[DigestError , URLException] m (Path Abs)
+               -> Excepts '[DigestError , DownloadFailed] m (Path Abs)
 downloadCached dli mfn = do
   cache <- lift getCache
   case cache of
@@ -238,11 +347,24 @@ downloadCached dli mfn = do
       liftE $ download dli tmp mfn
 
 
+
+
+    ------------------
+    --[ Low-level ]--
+    ------------------
+
+
 -- | This is used for downloading the JSON.
 downloadBS :: (MonadCatch m, MonadIO m)
            => URI
            -> Excepts
-                '[FileDoesNotExistError , URLException]
+                '[ FileDoesNotExistError
+                 , HTTPStatusError
+                 , URIParseError
+                 , UnsupportedScheme
+                 , NoLocationHeader
+                 , TooManyRedirs
+                 ]
                 m
                 L.ByteString
 downloadBS uri'
@@ -251,66 +373,231 @@ downloadBS uri'
   | scheme == [s|http|]
   = dl False
   | scheme == [s|file|]
-  = liftException doesNotExistErrorType (FileDoesNotExistError path)
-    $ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString)
+  = liftIOException doesNotExistErrorType (FileDoesNotExistError path)
+    $ (liftIO $ RD.readFile path)
   | otherwise
-  = throwE UnsupportedURL
+  = throwE UnsupportedScheme
 
  where
   scheme = view (uriSchemeL' % schemeBSL') uri'
   path   = view pathL' uri'
   dl https = do
-    host <-
-      preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
-        ?? UnsupportedURL
-    let port = preview
-          (authorityL' % _Just % authorityPortL' % _Just % portNumberL')
-          uri'
-    liftIO $ downloadBS' https host path port
+    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+    liftE $ downloadBS' https host' fullPath' port'
 
 
 -- | Load the result of this download into memory at once.
-downloadBS' :: Bool             -- ^ https?
+downloadBS' :: MonadIO m
+            => Bool             -- ^ https?
             -> ByteString       -- ^ host (e.g. "www.example.com")
-            -> ByteString       -- ^ path (e.g. "/my/file")
+            -> ByteString       -- ^ path (e.g. "/my/file") including query
             -> Maybe Int        -- ^ optional port (e.g. 3000)
-            -> IO (L.ByteString)
+            -> Excepts
+                 '[ HTTPStatusError
+                  , URIParseError
+                  , UnsupportedScheme
+                  , NoLocationHeader
+                  , TooManyRedirs
+                  ]
+                 m
+                 (L.ByteString)
 downloadBS' https host path port = do
-  bref <- newIORef (mempty :: Builder)
+  bref <- liftIO $ newIORef (mempty :: Builder)
   let stepper bs = modifyIORef bref (<> byteString bs)
-  downloadInternal https host path port stepper
-  readIORef bref <&> toLazyByteString
+  downloadInternal False https host path port stepper
+  liftIO (readIORef bref <&> toLazyByteString)
 
 
-downloadInternal :: Bool
-                 -> ByteString
-                 -> ByteString
-                 -> Maybe Int
-                 -> (ByteString -> IO a)        -- ^ the consuming step function
-                 -> IO ()
-downloadInternal https host path port consumer = do
-  c <- case https of
+downloadInternal :: MonadIO m
+                 => Bool        -- ^ whether to show a progress bar
+                 -> Bool        -- ^ https?
+                 -> ByteString  -- ^ host
+                 -> ByteString  -- ^ path with query
+                 -> Maybe Int   -- ^ optional port
+                 -> (ByteString -> IO a)   -- ^ the consuming step function
+                 -> Excepts
+                      '[ HTTPStatusError
+                       , URIParseError
+                       , UnsupportedScheme
+                       , NoLocationHeader
+                       , TooManyRedirs
+                       ]
+                      m
+                      ()
+downloadInternal = go (5 :: Int)
+
+ where
+  go redirs progressBar https host path port consumer = do
+    r <- liftIO $ withConnection' https host port action
+    veitherToExcepts r >>= \case
+      Just r' ->
+        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
+      Nothing -> pure ()
+   where
+    action c = do
+      let q = buildRequest1 $ http GET path
+
+      sendRequest c q emptyBody
+
+      receiveResponse
+        c
+        (\r i' -> runE $ do
+          let scode = getStatusCode r
+          if
+            | scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
+            | scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
+              Just r' -> pure $ Just $ r'
+              Nothing -> throwE NoLocationHeader
+            | otherwise -> throwE $ HTTPStatusError scode
+        )
+
+    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+      Right uri' -> do
+        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        go (redirs - 1) progressBar https' host' fullPath' port' consumer
+      Left e -> throwE e
+
+    downloadStream r i' = do
+      let size = case getHeader r [s|Content-Length|] of
+            Just x' -> case decimal $ E.decodeUtf8 x' of
+              Left  _       -> 0
+              Right (r', _) -> r'
+            Nothing -> 0
+
+      mpb <- if progressBar
+        then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
+        else pure Nothing
+
+      outStream <- liftIO $ Streams.makeOutputStream
+        (\case
+          Just bs -> do
+            forM_ mpb $ \pb -> incProgress pb (BS.length bs)
+            void $ consumer bs
+          Nothing -> pure ()
+        )
+      liftIO $ Streams.connect i' outStream
+
+
+
+getHead :: (MonadCatch m, MonadIO m)
+        => URI
+        -> Excepts
+             '[ HTTPStatusError
+              , URIParseError
+              , UnsupportedScheme
+              , NoLocationHeader
+              , TooManyRedirs
+              ]
+             m
+             (M.Map (CI ByteString) ByteString)
+getHead uri' | scheme == [s|https|] = head' True
+             | scheme == [s|http|] = head' False
+             | otherwise           = throwE UnsupportedScheme
+
+ where
+  scheme = view (uriSchemeL' % schemeBSL') uri'
+  head' https = do
+    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+    liftE $ headInternal https host' fullPath' port'
+
+
+
+headInternal :: MonadIO m
+             => Bool        -- ^ https?
+             -> ByteString  -- ^ host
+             -> ByteString  -- ^ path with query
+             -> Maybe Int   -- ^ optional port
+             -> Excepts
+                  '[ HTTPStatusError
+                   , URIParseError
+                   , UnsupportedScheme
+                   , TooManyRedirs
+                   , NoLocationHeader
+                   ]
+                  m
+                  (M.Map (CI ByteString) ByteString)
+headInternal = go (5 :: Int)
+
+ where
+  go redirs https host path port = do
+    r <- liftIO $ withConnection' https host port action
+    veitherToExcepts r >>= \case
+      Left r' ->
+        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
+      Right hs -> pure hs
+   where
+
+    action c = do
+      let q = buildRequest1 $ http HEAD path
+
+      sendRequest c q emptyBody
+
+      unsafeReceiveResponse
+        c
+        (\r _ -> runE $ do
+          let scode = getStatusCode r
+          if
+            | scode >= 200 && scode < 300 -> do
+              let headers = getHeaderMap r
+              pure $ Right $ headers
+            | scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
+              Just r' -> pure $ Left $ r'
+              Nothing -> throwE NoLocationHeader
+            | otherwise -> throwE $ HTTPStatusError scode
+        )
+
+    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+      Right uri' -> do
+        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        go (redirs - 1) https' host' fullPath' port'
+      Left e -> throwE e
+
+
+withConnection' :: Bool
+                -> ByteString
+                -> Maybe Int
+                -> (Connection -> IO a)
+                -> IO a
+withConnection' https host port action = bracket acquire closeConnection action
+
+ where
+  acquire = case https of
     True -> do
       ctx <- baselineContextSSL
       openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
     False -> openConnection host (fromIntegral $ fromMaybe 80 port)
 
-  let q = buildRequest1 $ http GET path
 
-  sendRequest c q emptyBody
+-- | 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
 
-  receiveResponse
-    c
-    (\_ i' -> do
-      outStream <- Streams.makeOutputStream
-        (\case
-          Just bs -> void $ consumer bs
-          Nothing -> pure ()
-        )
-      Streams.connect i' outStream
-    )
+  host <-
+    preview (_Just % authorityHostL' % hostBSL') uriAuthority
+      ?? UnsupportedScheme
 
-  closeConnection c
+  https <- if
+    | scheme == [s|https|] -> pure True
+    | scheme == [s|http|] -> pure False
+    | otherwise           -> throwE UnsupportedScheme
+
+  let
+    queryBS =
+      BS.intercalate [s|&|]
+        . fmap (\(x, y) -> encodeQuery x <> [s|=|] <> encodeQuery y)
+        $ (queryPairs uriQuery)
+    port =
+      preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
+    fullpath =
+      if BS.null queryBS then uriPath else uriPath <> [s|?|] <> queryBS
+  pure (https, host, fullpath, port)
+  where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery
 
 
 checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m)
@@ -326,4 +613,3 @@ checkDigest dli file = do
     let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
         eDigest = view dlHash dli
     when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
-

lib/GHCup/Errors.hs

@@ -1,3 +1,8 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DataKinds #-}
+
 module GHCup.Errors where
 
 import           GHCup.Types
@@ -5,59 +10,115 @@ import           GHCup.Types
 import           Control.Exception.Safe
 import           Data.ByteString                ( ByteString )
 import           Data.Text                      ( Text )
+import           Data.Versions
+import           Haskus.Utils.Variant
 import           HPath
 
 
+
+    ------------------------
+    --[ Low-level errors ]--
+    ------------------------
+
+
+
 -- | A compatible platform could not be found.
-data PlatformResultError = NoCompatiblePlatform String -- the platform we got
+data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got
   deriving Show
 
+-- | Unable to find a download for the requested versio/distro.
 data NoDownload = NoDownload
   deriving Show
 
+-- | The Architecture is unknown and unsupported.
 data NoCompatibleArch = NoCompatibleArch String
   deriving Show
 
+-- | Unable to figure out the distribution of the host.
 data DistroNotFound = DistroNotFound
   deriving Show
 
-data ArchiveError = UnknownArchive ByteString
+-- | The archive format is unknown. We don't know how to extract it.
+data UnknownArchive = UnknownArchive ByteString
   deriving Show
 
-data URLException = UnsupportedURL
+-- | The scheme is not supported (such as ftp).
+data UnsupportedScheme = UnsupportedScheme
   deriving Show
 
-data FileError = CopyError String
+-- | Unable to copy a file.
+data CopyError = CopyError String
   deriving Show
 
+-- | Unable to find a tag of a tool.
 data TagNotFound = TagNotFound Tag Tool
   deriving Show
 
-data AlreadyInstalled = AlreadyInstalled ToolRequest
+-- | The tool (such as GHC) is already installed with that version.
+data AlreadyInstalled = AlreadyInstalled Tool Version
   deriving Show
 
-data NotInstalled = NotInstalled ToolRequest
-  deriving Show
-
-data NotSet = NotSet Tool
+-- | The tool is not installed. Some operations rely on a tool
+-- to be installed (such as setting the current GHC version).
+data NotInstalled = NotInstalled Tool Version
   deriving Show
 
+-- | JSON decoding failed.
 data JSONError = JSONDecodeError String
   deriving Show
 
+-- | A file that is supposed to exist does not exist
+-- (e.g. when we use file scheme to "download" something).
+data FileDoesNotExistError = FileDoesNotExistError ByteString
+  deriving Show
+
+-- | File digest verification failed.
+data DigestError = DigestError Text Text
+  deriving Show
+
+-- | Unexpected HTTP status.
+data HTTPStatusError = HTTPStatusError Int
+  deriving Show
+
+-- | The 'Location' header was expected during a 3xx redirect, but not found.
+data NoLocationHeader = NoLocationHeader
+  deriving Show
+
+-- | Too many redirects.
+data TooManyRedirs = TooManyRedirs
+  deriving Show
+
+
+
+    -------------------------
+    --[ High-level errors ]--
+    -------------------------
+
+-- | A download failed. The underlying error is encapsulated.
+data DownloadFailed = forall es . Show (V es) => DownloadFailed (V es)
+
+deriving instance Show DownloadFailed
+
+
+-- | A build failed.
+data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
+
+deriving instance Show BuildFailed
+
+
+-- | Setting the current GHC version failed.
+data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
+
+deriving instance Show GHCupSetError
+
+
+    ---------------------------------------------
+    --[ True Exceptions (e.g. for MonadThrow) ]--
+    ---------------------------------------------
+
+
+-- | Parsing failed.
 data ParseError = ParseError String
   deriving Show
 
 instance Exception ParseError
-
-data FileDoesNotExistError = FileDoesNotExistError ByteString
-  deriving Show
-
-data GHCNotFound = GHCNotFound
-  deriving Show
-
-data BuildConfigNotFound = BuildConfigNotFound (Path Abs)
-  deriving Show
-
-data DigestError = DigestError Text Text
-  deriving Show

lib/GHCup/Platform.hs

@@ -54,7 +54,7 @@ getArchitecture = case arch of
 
 getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
             => Excepts
-                 '[PlatformResultError , DistroNotFound]
+                 '[NoCompatiblePlatform , DistroNotFound]
                  m
                  PlatformResult
 getPlatform = do

lib/GHCup/Types.hs

@@ -12,6 +12,97 @@ import qualified GHC.Generics                  as GHC
 
 
 
+
+    ---------------------
+    --[ Download Tree ]--
+    ---------------------
+
+
+-- | Description of all binary and source downloads. This is a tree
+-- of nested maps.
+type GHCupDownloads = Map Tool ToolVersionSpec
+type ToolVersionSpec = Map Version VersionInfo
+type ArchitectureSpec = Map Architecture PlatformSpec
+type PlatformSpec = Map Platform PlatformVersionSpec
+type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
+
+
+-- | An installable tool.
+data Tool = GHC
+          | Cabal
+          | GHCup
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+
+-- | All necessary information of a tool version, including
+-- source download and per-architecture downloads.
+data VersionInfo = VersionInfo
+  { _viTags     :: [Tag]              -- ^ version specific tag
+  , _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
+  , _viArch     :: ArchitectureSpec   -- ^ descend for binary downloads per arch
+  }
+  deriving (Eq, Show)
+
+
+-- | A tag. These are currently attached to a version of a tool.
+data Tag = Latest
+         | Recommended
+         deriving (Ord, Eq, Show)
+
+
+data Architecture = A_64
+                  | A_32
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+
+data Platform = Linux LinuxDistro
+              -- ^ must exit
+              | Darwin
+              -- ^ must exit
+              | FreeBSD
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+data LinuxDistro = Debian
+                 | Ubuntu
+                 | Mint
+                 | Fedora
+                 | CentOS
+                 | RedHat
+                 | Alpine
+                 | AmazonLinux
+                 -- rolling
+                 | Gentoo
+                 | Exherbo
+                 -- not known
+                 | UnknownLinux
+                 -- ^ must exit
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+
+-- | An encapsulation of a download. This can be used
+-- to download, extract and install a tool.
+data DownloadInfo = DownloadInfo
+  { _dlUri    :: URI
+  , _dlSubdir :: Maybe (Path Rel)
+  , _dlHash   :: Text
+  }
+  deriving (Eq, Show)
+
+
+
+
+    --------------
+    --[ Others ]--
+    --------------
+
+
+-- | Where to fetch GHCupDownloads from.
+data URLSource = GHCupURL
+               | OwnSource URI
+               | OwnSpec GHCupDownloads
+               deriving Show
+
+
 data Settings = Settings
   { cache     :: Bool
   , urlSource :: URLSource
@@ -33,67 +124,11 @@ data DebugInfo = DebugInfo
 
 
 data SetGHC = SetGHCOnly  -- ^ unversioned 'ghc'
-            | SetGHCMajor -- ^ ghc-x.y
-            | SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename
+            | SetGHC_XY   -- ^ ghc-x.y
+            | SetGHC_XYZ  -- ^ ghc-x.y.z
             deriving (Eq, Show)
 
 
-data Tag = Latest
-         | Recommended
-         deriving (Ord, Eq, Show)
-
-data VersionInfo = VersionInfo
-  { _viTags :: [Tag]
-  , _viArch :: ArchitectureSpec
-  }
-  deriving (Eq, Show)
-
-data DownloadInfo = DownloadInfo
-  { _dlUri    :: URI
-  , _dlSubdir :: Maybe (Path Rel)
-  , _dlHash   :: Text
-  }
-  deriving (Eq, Show)
-
-data Tool = GHC
-          | GHCSrc
-          | Cabal
-          | GHCup
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-data ToolRequest = ToolRequest
-  { _trTool    :: Tool
-  , _trVersion :: Version
-  }
-  deriving (Eq, Show)
-
-data Architecture = A_64
-                  | A_32
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-data LinuxDistro = Debian
-                 | Ubuntu
-                 | Mint
-                 | Fedora
-                 | CentOS
-                 | RedHat
-                 | Alpine
-                 | AmazonLinux
-                 -- rolling
-                 | Gentoo
-                 | Exherbo
-                 -- not known
-                 | UnknownLinux
-                 -- ^ must exit
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-data Platform = Linux LinuxDistro
-              -- ^ must exit
-              | Darwin
-              -- ^ must exit
-              | FreeBSD
-  deriving (Eq, GHC.Generic, Ord, Show)
-
 data PlatformResult = PlatformResult
   { _platform      :: Platform
   , _distroVersion :: Maybe Versioning
@@ -107,21 +142,3 @@ data PlatformRequest = PlatformRequest
   }
   deriving (Eq, Show)
 
-type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
-type PlatformSpec = Map Platform PlatformVersionSpec
-type ArchitectureSpec = Map Architecture PlatformSpec
-type ToolVersionSpec = Map Version VersionInfo
-type BinaryDownloads = Map Tool ToolVersionSpec
-
-type SourceDownloads = Map Version DownloadInfo
-
-data GHCupDownloads = GHCupDownloads {
-    _binaryDownloads :: BinaryDownloads
-  , _sourceDownloads :: SourceDownloads
-} deriving Show
-
-data URLSource = GHCupURL
-               | OwnSource URI
-               | OwnSpec GHCupDownloads
-               deriving Show
-

lib/GHCup/Types/JSON.hs

@@ -40,7 +40,6 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupDownloads
 
 
 instance ToJSON URI where

lib/GHCup/Types/Optics.hs

@@ -15,11 +15,9 @@ makePrisms ''Platform
 makePrisms ''Tag
 
 makeLenses ''PlatformResult
-makeLenses ''ToolRequest
 makeLenses ''DownloadInfo
 makeLenses ''Tag
 makeLenses ''VersionInfo
-makeLenses ''GHCupDownloads
 
 
 uriSchemeL' :: Lens' (URIRef Absolute) Scheme
@@ -45,3 +43,6 @@ hostBSL' = lensVL hostBSL
 
 pathL' :: Lens' (URIRef a) ByteString
 pathL' = lensVL pathL
+
+queryL' :: Lens' (URIRef a) Query
+queryL' = lensVL queryL

lib/GHCup/Utils.hs

@@ -43,6 +43,7 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           Safe
+import           System.IO.Error
 import           System.Posix.FilePath          ( takeFileName )
 import           System.Posix.Files.ByteString  ( readSymbolicLink )
 import           URI.ByteString
@@ -83,6 +84,51 @@ ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
       Right r -> pure r
 
 
+-- e.g. ghc-8.6.5
+rmMinorSymlinks :: (MonadIO m, MonadLogger m) => Version -> m ()
+rmMinorSymlinks ver = do
+  bindir <- liftIO $ ghcupBinDir
+  files  <- liftIO $ getDirsFiles' bindir
+  let myfiles =
+        filter (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x) files
+  forM_ myfiles $ \f -> do
+    let fullF = (bindir </> f)
+    $(logDebug) [i|rm -f #{toFilePath fullF}|]
+    liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
+
+-- E.g. ghc, if this version is the set one.
+-- This reads `ghcupGHCDir`.
+rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
+        => Version
+        -> Excepts '[NotInstalled] m ()
+rmPlain ver = do
+  files  <- liftE $ ghcToolFiles ver
+  bindir <- liftIO $ ghcupBinDir
+  forM_ files $ \f -> do
+    let fullF = (bindir </> f)
+    lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
+    liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
+  -- old ghcup
+  let hdc_file = (bindir </> [rel|haddock-ghc|])
+  lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
+  liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
+
+-- e.g. ghc-8.6
+rmMajorSymlinks :: (MonadLogger m, MonadIO m) => Version -> m ()
+rmMajorSymlinks ver = do
+  (mj, mi) <- liftIO $ getGHCMajor ver
+  let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
+
+  bindir <- liftIO ghcupBinDir
+
+  files  <- liftIO $ getDirsFiles' bindir
+  let myfiles = filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
+  forM_ myfiles $ \f -> do
+    let fullF = (bindir </> f)
+    $(logDebug) [i|rm -f #{toFilePath fullF}|]
+    liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
+
+
 
 
     -----------------------------------
@@ -90,12 +136,25 @@ ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
     -----------------------------------
 
 
+toolAlreadyInstalled :: Tool -> Version -> IO Bool
+toolAlreadyInstalled tool ver = case tool of
+  GHC   -> ghcInstalled ver
+  Cabal -> cabalInstalled ver
+  GHCup -> pure True
+
+
 ghcInstalled :: Version -> IO Bool
 ghcInstalled ver = do
   ghcdir <- ghcupGHCDir ver
   doesDirectoryExist ghcdir
 
 
+ghcSrcInstalled :: Version -> IO Bool
+ghcSrcInstalled ver = do
+  ghcdir <- ghcupGHCDir ver
+  doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
+
+
 ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
 ghcSet = do
   ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
@@ -108,10 +167,8 @@ ghcSet = do
 
 cabalInstalled :: Version -> IO Bool
 cabalInstalled ver = do
-  cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir
-  mc       <- executeOut cabalbin [[s|--numeric-version|]] Nothing
-  let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
-  pure (reportedVer == (verToBS ver))
+  reportedVer <- cabalSet
+  pure (reportedVer == ver)
 
 cabalSet :: (MonadIO m, MonadThrow m) => m Version
 cabalSet = do
@@ -169,7 +226,7 @@ getGHCForMajor major' minor' = do
 unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
             => Path Abs       -- ^ destination dir
             -> Path Abs       -- ^ archive path
-            -> Excepts '[ArchiveError] m ()
+            -> Excepts '[UnknownArchive] m ()
 unpackToDir dest av = do
   let fp = E.decodeUtf8 (toFilePath av)
   lift $ $(logInfo) [i|Unpacking: #{fp}|]
@@ -198,7 +255,7 @@ unpackToDir dest av = do
 
 
 -- | Get the tool versions that have this tag.
-getTagged :: BinaryDownloads -> Tool -> Tag -> [Version]
+getTagged :: GHCupDownloads -> Tool -> Tag -> [Version]
 getTagged av tool tag = toListOf
   ( ix tool
   % to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
@@ -207,10 +264,10 @@ getTagged av tool tag = toListOf
   )
   av
 
-getLatest :: BinaryDownloads -> Tool -> Maybe Version
+getLatest :: GHCupDownloads -> Tool -> Maybe Version
 getLatest av tool = headOf folded $ getTagged av tool Latest
 
-getRecommended :: BinaryDownloads -> Tool -> Maybe Version
+getRecommended :: GHCupDownloads -> Tool -> Maybe Version
 getRecommended av tool = headOf folded $ getTagged av tool Recommended
 
 
@@ -241,24 +298,33 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
 
 -- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
 -- while ignoring *-<ver> symlinks.
+--
+-- Returns unversioned relative files, e.g.:
+--   ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
 ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
              => Version
              -> Excepts '[NotInstalled] m [Path Rel]
 ghcToolFiles ver = do
   ghcdir <- liftIO $ ghcupGHCDir ver
+  let bindir = ghcdir </> [rel|bin|]
 
   -- fail if ghc is not installed
   whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
-        (throwE (NotInstalled $ ToolRequest GHC ver))
+        (throwE (NotInstalled GHC ver))
 
-  files         <- liftIO $ getDirsFiles' (ghcdir </> ([rel|bin|] :: Path Rel))
+  files         <- liftIO $ getDirsFiles' bindir
   -- figure out the <ver> suffix, because this might not be `Version` for
   -- alpha/rc releases, but x.y.a.somedate.
   (Just symver) <-
     (B.stripPrefix [s|ghc-|] . takeFileName)
-      <$> (liftIO $ readSymbolicLink $ toFilePath
-            (ghcdir </> ([rel|bin/ghc|] :: Path Rel))
-          )
+      <$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> [rel|ghc|]))
   when (B.null symver)
        (throwIO $ userError $ "Fatal: ghc symlink target is broken")
+
   pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
+
+
+-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
+-- this GHC was built from source. It contains the build config.
+ghcUpSrcBuiltFile :: Path Rel
+ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]

lib/GHCup/Utils/Dirs.hs

@@ -76,7 +76,6 @@ withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
 withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
 
 
-
     --------------
     --[ Others ]--
     --------------

lib/GHCup/Utils/File.hs

@@ -134,7 +134,7 @@ execLogged exe spath args lfile chdir env = do
 
 
     SPPB.getProcessStatus True True pid >>= \case
-      i@(Just (SPPB.Exited es)) -> pure $ toProcessError exe args i
+      i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
       i                         -> pure $ toProcessError exe args i
 
 
@@ -219,9 +219,9 @@ toProcessError exe args mps = case mps of
 -- | Convert the String to a ByteString with the current
 -- system encoding.
 unsafePathToString :: Path b -> IO FilePath
-unsafePathToString (Path p) = do
+unsafePathToString p = do
   enc <- getLocaleEncoding
-  unsafeUseAsCStringLen p (peekCStringLen enc)
+  unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
 
 
 -- | Search for a file in the search paths.

lib/GHCup/Utils/Logger.hs

@@ -4,6 +4,7 @@ module GHCup.Utils.Logger where
 
 import           GHCup.Utils
 
+import           Control.Monad
 import           Control.Monad.Logger
 import           HPath
 import           HPath.IO
@@ -28,15 +29,15 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
   mylogger _ _ level str' = do
     -- color output
     let l = case level of
-          LevelDebug -> if lcPrintDebug
-            then toLogStr (style Bold $ color Blue "[ Debug ]")
-            else mempty
+          LevelDebug   -> toLogStr (style Bold $ color Blue "[ Debug ]")
           LevelInfo    -> toLogStr (style Bold $ color Green "[ Info  ]")
           LevelWarn    -> toLogStr (style Bold $ color Yellow "[ Warn  ]")
           LevelError   -> toLogStr (style Bold $ color Red "[ Error ]")
           LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
     let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
-    colorOutter out
+
+    when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
+      $ colorOutter out
 
     -- raw output
     let lr = case level of

lib/GHCup/Utils/Prelude.hs

@@ -1,11 +1,12 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveLift #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveLift          #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module GHCup.Utils.Prelude where
 
@@ -23,6 +24,7 @@ import           Data.Versions
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
 import           System.IO.Error
+import           System.Posix.Env.ByteString    ( getEnvironment )
 
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
@@ -136,17 +138,17 @@ fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
 
 
-liftException :: ( MonadCatch m
-                 , MonadIO m
-                 , Monad m
-                 , e :< es'
-                 , LiftVariant es es'
-                 )
-              => IOErrorType
-              -> e
-              -> Excepts es m a
-              -> Excepts es' m a
-liftException errType ex =
+liftIOException' :: ( MonadCatch m
+                    , MonadIO m
+                    , Monad m
+                    , e :< es'
+                    , LiftVariant es es'
+                    )
+                 => IOErrorType
+                 -> e
+                 -> Excepts es m a
+                 -> Excepts es' m a
+liftIOException' errType ex =
   handleIO
       (\e ->
         if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
@@ -154,6 +156,19 @@ liftException errType ex =
     . liftE
 
 
+liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')
+                => IOErrorType
+                -> e
+                -> m a
+                -> Excepts es' m a
+liftIOException errType ex =
+  handleIO
+      (\e ->
+        if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
+      )
+    . lift
+
+
 hideErrorDef :: IOErrorType -> a -> IO a -> IO a
 hideErrorDef err def =
   handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e)
@@ -174,6 +189,7 @@ hideExcept :: forall e es es' a m
 hideExcept _ a action =
   catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
 
+
 hideExcept' :: forall e es es' m
              . (Monad m, e :< es, LiftVariant (Remove e es) es')
             => e
@@ -183,6 +199,23 @@ hideExcept' _ action =
   catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
 
 
+reThrowAll :: forall e es es' a m
+            . (Monad m, e :< es')
+           => (V es -> e)
+           -> Excepts es m a
+           -> Excepts es' m a
+reThrowAll f = catchAllE (throwE . f)
+
+
+reThrowAllIO :: forall e es es' a m
+              . (MonadCatch m, Monad m, MonadIO m, e :< es')
+             => (V es -> e)
+             -> (IOException -> e)
+             -> Excepts es m a
+             -> Excepts es' m a
+reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)
+
+
 throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
 throwEither a = case a of
   Left  e -> throwM e
@@ -200,3 +233,11 @@ intToText = TL.toStrict . B.toLazyText . B.decimal
 removeLensFieldLabel :: String -> String
 removeLensFieldLabel str' =
   maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
+
+
+addToCurrentEnv :: MonadIO m
+                => [(ByteString, ByteString)]
+                -> m [(ByteString, ByteString)]
+addToCurrentEnv adds = do
+  cEnv <- liftIO $ getEnvironment
+  pure (adds ++ cEnv)