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,36 +2,40 @@
 
 ## Now
 
-* better logs
-* better debug-output
+* print-system-reqs
 
-* static builds
+## 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/BinaryDownloads.hs

@@ -1,161 +0,0 @@
-{-# LANGUAGE QuasiQuotes       #-}
-
-
-module BinaryDownloads where
-
-import           GHCup.Types
-import           GHCup.Utils.Prelude
-
-import           Data.String.QQ
-import           HPath
-import           URI.ByteString.QQ
-
-import qualified Data.Map                      as M
-
-
-    -----------------
-    --[ GHC 8.4.4 ]--
-    -----------------
-
-
-ghc_844_64_fedora :: DownloadInfo
-ghc_844_64_fedora = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-fedora27-linux.tar.xz|]
-  (Just ([rel|ghc-8.4.4|] :: Path Rel))
-  [s|5f871a3eaf808acb2420fdeef9318698|]
-
-ghc_844_64_debian9 :: DownloadInfo
-ghc_844_64_debian9 = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-deb9-linux.tar.xz|]
-  (Just ([rel|ghc-8.4.4|] :: Path Rel))
-  [s|5f871a3eaf808acb2420fdeef9318698|]
-
-ghc_844_64_debian8 :: DownloadInfo
-ghc_844_64_debian8 = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-deb8-linux.tar.xz|]
-  (Just ([rel|ghc-8.4.4|] :: Path Rel))
-  [s|5f871a3eaf808acb2420fdeef9318698|]
-
-
-    -----------------
-    --[ GHC 8.6.5 ]--
-    -----------------
-
-
-
-ghc_865_64_fedora :: DownloadInfo
-ghc_865_64_fedora = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
-  (Just ([rel|ghc-8.6.5|] :: Path Rel))
-  [s|5f871a3eaf808acb2420fdeef9318698|]
-
-ghc_865_64_debian9 :: DownloadInfo
-ghc_865_64_debian9 = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|]
-  (Just ([rel|ghc-8.6.5|] :: Path Rel))
-  [s|8de779b73c1b2f1b7ab49030015fce3d|]
-
-ghc_865_64_debian8 :: DownloadInfo
-ghc_865_64_debian8 = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb8-linux.tar.xz|]
-  (Just ([rel|ghc-8.6.5|] :: Path Rel))
-  [s|5f871a3eaf808acb2420fdeef9318698|]
-
-
-    ---------------------
-    --[ Cabal-3.0.0.0 ]--
-    ---------------------
-
-
-cabal_3000_64_linux :: DownloadInfo
-cabal_3000_64_linux = DownloadInfo
-  [uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|]
-  Nothing
-  [s|32352d2259909970e6ff04faf61bbfac|]
-
-
-
-    -------------
-    --[ GHCup ]--
-    -------------
-
-
-ghcup_010_64_linux :: DownloadInfo
-ghcup_010_64_linux = DownloadInfo [uri|file:///home/ospa_ju/tmp/ghcup-exe|]
-                                  Nothing
-                                  [s|d8da9e09ca71648f4c1bc6a0a46efc82|]
-
-
-
-
-    -----------------------
-    --[ Tarball mapping ]--
-    -----------------------
-
-
-binaryDownloads :: BinaryDownloads
-binaryDownloads = M.fromList
-  [ ( GHC
-    , M.fromList
-      [ ( [vver|8.6.5|]
-        , VersionInfo [Latest] $ M.fromList
-          [ ( A_64
-            , M.fromList
-              [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_865_64_fedora)])
-              , (Linux Ubuntu      , M.fromList [(Nothing, ghc_865_64_debian9)])
-              , ( Linux Debian
-                , M.fromList
-                  [ (Nothing         , ghc_865_64_debian9)
-                  , (Just $ [vers|8|], ghc_865_64_debian8)
-                  ]
-                )
-              ]
-            )
-          ]
-        )
-      , ( [vver|8.4.4|]
-        , VersionInfo [] $ M.fromList
-          [ ( A_64
-            , M.fromList
-              [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_844_64_fedora)])
-              , (Linux Ubuntu      , M.fromList [(Nothing, ghc_844_64_fedora)])
-              , ( Linux Debian
-                , M.fromList
-                  [ (Nothing         , ghc_844_64_debian9)
-                  , (Just $ [vers|8|], ghc_844_64_debian8)
-                  ]
-                )
-              ]
-            )
-          ]
-        )
-      ]
-    )
-  , ( Cabal
-    , M.fromList
-      [ ( [vver|3.0.0.0|]
-        , VersionInfo [Recommended, Latest] $ M.fromList
-          [ ( A_64
-            , M.fromList
-              [ ( Linux UnknownLinux
-                , M.fromList [(Nothing, cabal_3000_64_linux)]
-                )
-              ]
-            )
-          ]
-        )
-      ]
-    )
-  , ( GHCup
-    , M.fromList
-      [ ( [vver|0.1.0|]
-        , VersionInfo [Latest] $ M.fromList
-          [ ( A_64
-            , M.fromList
-              [(Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])]
-            )
-          ]
-        )
-      ]
-    )
-  ]

app/ghcup-gen/Main.hs

@@ -21,7 +21,7 @@ import           System.Exit
 import           System.IO                      ( stdout )
 import           Validate
 
-import qualified Data.ByteString as B
+import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as L
 
 
@@ -31,6 +31,7 @@ data Options = Options
 
 data Command = GenJSON GenJSONOpts
              | ValidateJSON ValidateJSONOpts
+             | ValidateTarballs ValidateJSONOpts
 
 data Output
   = FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
@@ -107,7 +108,16 @@ com = subparser
        "check"
        (   ValidateJSON
        <$> (info (validateJSONOpts <**> helper)
-                 (progDesc "Generate the json downloads file")
+                 (progDesc "Validate the JSON")
+           )
+       )
+     )
+  <> (command
+       "check-tarballs"
+       (   ValidateTarballs
+       <$> (info
+             (validateJSONOpts <**> helper)
+             (progDesc "Validate all tarballs (download and checksum)")
            )
        )
      )
@@ -130,16 +140,25 @@ main = do
                 L.writeFile file bs
           ValidateJSON vopts -> case vopts of
             ValidateJSONOpts { input = Nothing } ->
-              L.getContents >>= valAndExit
+              L.getContents >>= valAndExit validate
             ValidateJSONOpts { input = Just StdInput } ->
-              L.getContents >>= valAndExit
+              L.getContents >>= valAndExit validate
             ValidateJSONOpts { input = Just (FileInput file) } ->
-              L.readFile file >>= valAndExit
+              L.readFile file >>= valAndExit validate
+          ValidateTarballs vopts -> case vopts of
+            ValidateJSONOpts { input = Nothing } ->
+              L.getContents >>= valAndExit validateTarballs
+            ValidateJSONOpts { input = Just StdInput } ->
+              L.getContents >>= valAndExit validateTarballs
+            ValidateJSONOpts { input = Just (FileInput file) } ->
+              L.readFile file >>= valAndExit validateTarballs
   pure ()
 
  where
-  valAndExit contents = do
+  valAndExit f contents = do
     av <- case eitherDecode contents of
       Right r -> pure r
       Left  e -> die (color Red $ show e)
-    myLoggerT (LoggerConfig True (B.hPut stdout)) (validate av) >>= exitWith
+    myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
+      >>= exitWith
+

app/ghcup-gen/SourceDownloads.hs

@@ -1,26 +0,0 @@
-{-# LANGUAGE QuasiQuotes       #-}
-
-module SourceDownloads where
-
-
-import           GHCup.Types
-import           GHCup.Utils.Prelude
-
-import           Data.String.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

@@ -5,56 +5,72 @@
 module Validate where
 
 import           GHCup
+import           GHCup.Download
 import           GHCup.Types
+import           GHCup.Utils.Logger
 
-import           Control.Monad
 import           Control.Exception.Safe
-import           Control.Monad.Reader.Class
+import           Control.Monad
 import           Control.Monad.IO.Class
+import           Control.Monad.Logger
+import           Control.Monad.Reader.Class
 import           Control.Monad.Trans.Class      ( lift )
 import           Control.Monad.Trans.Reader     ( runReaderT )
+import           Control.Monad.Trans.Resource   ( runResourceT
+                                                , MonadUnliftIO
+                                                )
+import           Data.IORef
 import           Data.List
 import           Data.String.Interpolate
 import           Data.Versions
-import           Data.IORef
+import           Haskus.Utils.Variant.Excepts
+import           Optics
 import           System.Exit
-import           Control.Monad.Logger
+import           System.IO
 
+import qualified Data.ByteString               as B
 import qualified Data.Map.Strict               as M
 
 
--- TODO: improve logging
-
-
 data ValidationError = InternalError String
   deriving Show
 
 instance Exception ValidationError
 
 
--- TODO: test that GHC is in semver
--- TODO: check there's LATEST tag for every tool
-validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
+addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
+addError = do
+  ref <- ask
+  liftIO $ modifyIORef ref (+ 1)
+
+
+validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
          => GHCupDownloads
          -> m ExitCode
-validate 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 dls) $ \(t, _) -> checkMandatoryTags t
 
     -- exit
     e <- liftIO $ readIORef ref
-    if e > 0 then pure $ ExitFailure e else pure ExitSuccess
+    if e > 0
+      then pure $ ExitFailure e
+      else do
+        lift $ $(logInfo) [i|All good|]
+        pure ExitSuccess
  where
   checkHasRequiredPlatforms t v arch pspecs = do
     let v' = prettyVer v
@@ -62,14 +78,14 @@ validate GHCupDownloads{..} = do
       lift $ $(logError)
         [i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
       addError
-    when (not $ any (== Darwin) pspecs) $ do
+    when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
       lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
       addError
-    when (not $ any (== FreeBSD) pspecs) $ lift $ $(logWarn)
+    when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
       [i|FreeBSD missing for #{t} #{v'} #{arch}|]
 
   checkUniqueTags tool = do
-    let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool
+    let allTags = join $ fmap snd $ availableToolVersions dls tool
     let nonUnique =
           fmap fst
             .   filter (\(_, b) -> not b)
@@ -86,14 +102,80 @@ validate GHCupDownloads{..} = do
     case join nonUnique of
       [] -> pure ()
       xs -> do
-        lift $ $(logError) [i|Tags not unique: #{xs}|]
+        lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
         addError
    where
     isUniqueTag Latest      = True
     isUniqueTag Recommended = True
 
+  checkGHCisSemver = do
+    let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
+    forM_ ghcVers $ \v -> case semver (prettyVer v) of
+      Left _ -> do
+        lift $ $(logError) [i|GHC version #{v} is not valid semver|]
+        addError
+      Right _ -> pure ()
 
-addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
-addError = do
-  ref <- ask
-  liftIO $ modifyIORef ref (+ 1)
+  -- a tool must have at least one of each mandatory tags
+  checkMandatoryTags tool = do
+    let allTags = join $ fmap snd $ availableToolVersions dls tool
+    forM_ [Latest, Recommended] $ \t -> case elem t allTags of
+      False -> do
+        lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
+        addError
+      True -> pure ()
+
+
+validateTarballs :: ( Monad m
+                    , MonadLogger m
+                    , MonadThrow m
+                    , MonadIO m
+                    , MonadUnliftIO m
+                    , MonadMask m
+                    )
+                 => GHCupDownloads
+                 -> m ExitCode
+validateTarballs dls = do
+  ref <- liftIO $ newIORef 0
+
+  flip runReaderT ref $ do
+     -- download/verify all binary tarballs
+    let
+      dlbis = nub $ join $ (M.elems dls) <&> \versions ->
+        join $ (M.elems versions) <&> \vi ->
+          join $ (M.elems $ _viArch vi) <&> \pspecs ->
+            join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
+    forM_ dlbis $ downloadAll
+
+    let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
+          join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
+    forM_ dlsrc $ downloadAll
+
+    -- exit
+    e <- liftIO $ readIORef ref
+    if e > 0
+      then pure $ ExitFailure e
+      else do
+        lift $ $(logInfo) [i|All good|]
+        pure ExitSuccess
+
+ where
+  downloadAll dli = do
+    let settings = Settings True GHCupURL False
+    let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
+                                           , colorOutter  = B.hPut stderr
+                                           , rawOutter    = (\_ -> pure ())
+                                           }
+
+    r <-
+      runLogger
+      . flip runReaderT settings
+      . runResourceT
+      . runE
+      $ downloadCached dli Nothing
+    case r of
+      VRight _ -> pure ()
+      VLeft  e -> do
+        lift $ $(logError)
+          [i|Could not download (or verify hash) of #{dli}, Error was: #{e}|]
+        addError

app/ghcup/Main.hs

@@ -13,9 +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
@@ -25,15 +26,16 @@ import           Data.Char
 import           Data.List                      ( intercalate )
 import           Data.Semigroup                 ( (<>) )
 import           Data.String.Interpolate
-import           Data.String.QQ
 import           Data.Versions
 import           Haskus.Utils.Variant.Excepts
 import           HPath
+import           HPath.IO
 import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
 import           System.Console.Pretty
 import           System.Environment
 import           System.Exit
-import           System.IO
+import           System.IO               hiding ( appendFile )
 import           Text.Read
 import           Text.Layout.Table
 import           URI.ByteString
@@ -41,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
 
 
@@ -53,6 +56,7 @@ data Options = Options
     optVerbose   :: Bool
   , optCache     :: Bool
   , optUrlSource :: Maybe URI
+  , optNoVerify  :: Bool
   -- commands
   , optCommand   :: Command
   }
@@ -63,8 +67,9 @@ data Command
   | List ListOptions
   | Rm RmOptions
   | DInfo
-  | Compile CompileOptions
+  | Compile CompileCommand
   | Upgrade UpgradeOpts
+  | NumericVersion
 
 data ToolVersion = ToolVersion Version
                  | ToolTag Tag
@@ -91,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)
@@ -119,15 +128,20 @@ opts =
           (option
             (eitherReader parseUri)
             (short 's' <> long "url-source" <> metavar "URL" <> help
-              "Alternative ghcup download info url (default: internal)"
+              "Alternative ghcup download info url" <> internal
             )
           )
         )
+    <*> switch
+          (short 'n' <> long "no-verify" <> help
+            "Skip tarball checksum verification (default: False)"
+          )
     <*> com
  where
   parseUri s' =
     bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
 
+
 com :: Parser Command
 com =
   subparser
@@ -148,8 +162,18 @@ com =
       <> command
            "upgrade"
            (   Upgrade
-           <$> (info (upgradeOptsP <**> helper) (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)"))
+           <$> (info
+                 (upgradeOptsP <**> helper)
+                 (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
+               )
            )
+          <> command
+               "compile"
+               (   Compile
+               <$> (info (compileP <**> helper)
+                         (progDesc "Compile a tool from source")
+                   )
+               )
       <> commandGroup "Main commands:"
       )
     <|> subparser
@@ -168,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
           )
@@ -182,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
           )
@@ -234,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
@@ -242,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
@@ -320,6 +360,7 @@ toSettings :: Options -> Settings
 toSettings Options {..} =
   let cache     = optCache
       urlSource = maybe GHCupURL OwnSource optUrlSource
+      noVerify  = optNoVerify
   in  Settings { .. }
 
 
@@ -349,17 +390,20 @@ upgradeOptsP =
 
 
 
--- TODO: something better than Show instance for errors
-
 main :: IO ()
 main = do
 
   customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
     >>= \opt@Options {..} -> do
-          let settings  = toSettings opt
+          let settings = toSettings opt
 
           -- logger interpreter
-          let runLogger = myLoggerT (LoggerConfig optVerbose $ B.hPut stderr)
+          logfile <- initGHCupFileLogging ([rel|ghcup.log|] :: Path Rel)
+          let runLogger = myLoggerT LoggerConfig
+                { lcPrintDebug = optVerbose
+                , colorOutter  = B.hPut stderr
+                , rawOutter    = appendFile logfile
+                }
 
           -- wrapper to run effects with settings
           let runInstTool =
@@ -368,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 =
@@ -390,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]
@@ -407,7 +451,7 @@ main = do
                 runLogger
                   . flip runReaderT settings
                   . runE
-                    @'[PlatformResultError , NoCompatibleArch , DistroNotFound]
+                    @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
 
           let runCompileGHC =
                 runLogger
@@ -415,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
                       ]
 
 
@@ -447,38 +503,50 @@ 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|])
-                      VLeft e ->
-                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+                          [i|GHC ver #{prettyVer v} already installed|]
+                      VLeft (V (BuildFailed tmpdir e)) ->
+                        runLogger
+                            ($(logError) [i|Build failed with #{e}
+Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
+                            )
+                          >> exitFailure
+                      VLeft e -> do
+                        runLogger $ do
+                          $(logError) [i|#{e}|]
+                          $(logError) [i|Also check the logs in ~/.ghcup/logs|]
+                        exitFailure
             Install (InstallCabal InstallOptions {..}) ->
               void
                 $   (runInstTool $ do
-                      dls <- _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|])
-                      VLeft e ->
-                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+                          [i|Cabal ver #{prettyVer v} already installed|]
+                      VLeft e -> do
+                        runLogger $ do
+                          $(logError) [i|#{e}|]
+                          $(logError) [i|Also check the logs in ~/.ghcup/logs|]
+                        exitFailure
 
             SetGHC (SetGHCOptions {..}) ->
               void
                 $   (runSetGHC $ do
-                      dls <- _binaryDownloads <$> liftE getDownloads
+                      dls <- liftE getDownloads
                       v   <- liftE $ fromVersion dls ghcVer GHC
                       liftE $ setGHC v SetGHCOnly
                     )
@@ -491,7 +559,7 @@ main = do
             List (ListOptions {..}) ->
               void
                 $   (runListGHC $ do
-                      dls <- _binaryDownloads <$> liftE getDownloads
+                      dls <- liftE getDownloads
                       liftIO $ listVersions dls lTool lCriteria
                     )
                 >>= \case
@@ -519,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
@@ -544,26 +640,29 @@ main = do
                   pure $ Just p
                 (UpgradeAt p)   -> pure $ Just p
                 UpgradeGHCupDir -> do
-                  liftIO $ putStrLn "blah"
-                  pure Nothing
+                  bdir <- liftIO $ ghcupBinDir
+                  pure (Just (bdir </> ([rel|ghcup|] :: Path Rel)))
 
               void
                 $   (runUpgrade $ do
-                      dls <- _binaryDownloads <$> liftE getDownloads
+                      dls <- liftE getDownloads
                       liftE $ upgradeGHCup dls target
                     )
                 >>= \case
-                      VRight v' ->
-                        runLogger $ $(logInfo)
-                          [i|Successfully upgraded GHCup to version #{v'}|]
+                      VRight v' -> do
+                        let pretty_v = prettyVer v'
+                        runLogger
+                          $ $(logInfo)
+                              [i|Successfully upgraded GHCup to version #{pretty_v}|]
                       VLeft e ->
                         runLogger ($(logError) [i|#{e}|]) >> exitFailure
 
+            NumericVersion -> T.hPutStr stdout (prettyPVP ghcUpVer)
   pure ()
 
 
 fromVersion :: Monad m
-            => BinaryDownloads
+            => GHCupDownloads
             -> Maybe ToolVersion
             -> Tool
             -> Excepts '[TagNotFound] m Version
@@ -585,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 {..} ->
@@ -595,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,17 +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 string-qq { build-depends: string-qq >= 0.0.4 }
 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 }
@@ -97,8 +100,10 @@ library
                      , ascii-string
                      , async
                      , attoparsec
+                     , binary
                      , bytestring
                      , bzlib
+                     , case-insensitive
                      , containers
                      , generics-sop
                      , haskus-utils-types
@@ -127,11 +132,12 @@ library
                      , streamly-bytestring
                      , strict-base
                      , string-interpolate
-                     , string-qq
                      , tar-bytestring
                      , template-haskell
+                     , terminal-progress-bar
                      , text
                      , text-icu
+                     , time
                      , transformers
                      , unix
                      , unix-bytestring
@@ -150,9 +156,12 @@ library
                        GHCup.Types.Optics
                        GHCup.Utils
                        GHCup.Utils.Bash
+                       GHCup.Utils.Dirs
                        GHCup.Utils.File
                        GHCup.Utils.Logger
                        GHCup.Utils.Prelude
+                       GHCup.Utils.String.QQ
+                       GHCup.Utils.Version.QQ
                        GHCup.Version
   -- other-modules:
   -- other-extensions:
@@ -171,9 +180,9 @@ executable ghcup
                        , text
                        , versions
                        , hpath
+                       , hpath-io
                        , pretty-terminal
                        , resourcet
-                       , string-qq
                        , string-interpolate
                        , table-layout
                        , uri-bytestring
@@ -203,16 +212,14 @@ executable ghcup-gen
                        , versions
                        , hpath
                        , pretty-terminal
-                       , string-qq
+                       , resourcet
                        , string-interpolate
                        , table-layout
                        , transformers
                        , 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
 
 
@@ -21,6 +20,8 @@ import           GHCup.Types.Optics
 import           GHCup.Utils
 import           GHCup.Utils.File
 import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
+import           GHCup.Utils.Version.QQ
 import           GHCup.Version
 
 import           Control.Applicative
@@ -33,11 +34,9 @@ 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
-import           Data.String.QQ
 import           Data.Versions
 import           Data.Word8
 import           GHC.IO.Exception
@@ -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,56 +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|]
-  lEM $ liftIO $ exec [s|./configure|]
-                      False
-                      [[s|--prefix=|] <> toFilePath inst]
-                      (Just path)
-                      Nothing
-  lEM $ liftIO $ exec [s|make|] True [[s|install|]] (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
 
 
 
@@ -184,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 ()
@@ -201,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)
-
 
 
 
@@ -272,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]
@@ -292,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
@@ -300,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
@@ -314,8 +352,6 @@ listVersions av lt criteria = case lt of
 
 
 
-
-
     --------------
     --[ GHC rm ]--
     --------------
@@ -329,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
@@ -340,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)
 
 
 
@@ -403,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
@@ -418,44 +421,43 @@ getDebugInfo = do
 
 
 
+
     ---------------
     --[ Compile ]--
     ---------------
 
 
--- TODO: build config
-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
@@ -464,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
@@ -512,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
@@ -541,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)
+  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
 
@@ -559,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
@@ -17,10 +18,12 @@ import           GHCup.Types.Optics
 import           GHCup.Utils
 import           GHCup.Utils.File
 import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
 
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
+import           Control.Monad.Fail             ( MonadFail )
 import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Class      ( lift )
@@ -29,10 +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.String.QQ
+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 :: (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,19 +303,11 @@ 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
-    let p' = toFilePath destFile
-    lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
-    c <- liftIO $ readFile destFile
-    let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
-        eDigest = view dlHash dli
-    when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
+    liftE $ checkDigest dli destFile
     pure destFile
 
   -- Manage to find a file we can write the body into.
@@ -216,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
@@ -224,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
@@ -234,27 +338,33 @@ downloadCached dli mfn = do
       let cachfile = cachedir </> fn
       fileExists <- liftIO $ doesFileExist cachfile
       if
-        | fileExists
-        -> do
-          let cachfile' = toFilePath cachfile
-          lift $ $(logInfo) [i|veryfing digest of: #{cachfile'}|]
-          c <- liftIO $ readFile cachfile
-          let cDigest = E.decodeUtf8 . toHex . digest (digestByName "md5") $ c
-              eDigest = view dlHash dli
-          when (cDigest /= eDigest) $ throwE (DigestError cDigest eDigest)
+        | fileExists -> do
+          liftE $ checkDigest dli cachfile
           pure $ cachfile
-        | otherwise
-        -> liftE $ download dli cachedir mfn
+        | otherwise -> liftE $ download dli cachedir mfn
     False -> do
       tmp <- lift withGHCupTmpDir
       liftE $ download dli tmp mfn
 
 
+
+
+    ------------------
+    --[ Low-level ]--
+    ------------------
+
+
 -- | This is used for downloading the JSON.
 downloadBS :: (MonadCatch m, MonadIO m)
            => URI
            -> Excepts
-                '[FileDoesNotExistError , URLException]
+                '[ FileDoesNotExistError
+                 , HTTPStatusError
+                 , URIParseError
+                 , UnsupportedScheme
+                 , NoLocationHeader
+                 , TooManyRedirs
+                 ]
                 m
                 L.ByteString
 downloadBS uri'
@@ -263,63 +373,243 @@ 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)
+            => DownloadInfo
+            -> Path Abs
+            -> Excepts '[DigestError] m ()
+checkDigest dli file = do
+  verify <- lift ask <&> (not . noVerify)
+  when verify $ do
+    let p' = toFilePath file
+    lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
+    c <- liftIO $ readFile file
+    let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
+        eDigest = view dlHash dli
+    when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)

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

@@ -13,6 +13,7 @@ import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.Bash
 import           GHCup.Utils.File
 import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
 
 import           Control.Applicative
 import           Control.Exception.Safe
@@ -23,7 +24,6 @@ import           Control.Monad.Trans.Class      ( lift )
 import           Data.Foldable
 import           Data.Maybe
 import           Data.String.Interpolate
-import           Data.String.QQ
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           HPath
@@ -54,7 +54,7 @@ getArchitecture = case arch of
 
 getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
             => Excepts
-                 '[PlatformResultError , DistroNotFound]
+                 '[NoCompatiblePlatform , DistroNotFound]
                  m
                  PlatformResult
 getPlatform = do
@@ -96,6 +96,7 @@ getLinuxDistro = do
         | hasWord name ["alpine"]  -> Alpine
         | hasWord name ["exherbo"] -> Exherbo
         | hasWord name ["gentoo"]  -> Gentoo
+        | hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
         | otherwise                -> UnknownLinux
   pure (distro, parsedVer)
  where

lib/GHCup/Types.hs

@@ -12,9 +12,101 @@ import qualified GHC.Generics                  as GHC
 
 
 
+
+    ---------------------
+    --[ Download Tree ]--
+    ---------------------
+
+
+-- | Description of all binary and source downloads. This is a tree
+-- of nested maps.
+type GHCupDownloads = Map Tool ToolVersionSpec
+type ToolVersionSpec = Map Version VersionInfo
+type ArchitectureSpec = Map Architecture PlatformSpec
+type PlatformSpec = Map Platform PlatformVersionSpec
+type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
+
+
+-- | An installable tool.
+data Tool = GHC
+          | Cabal
+          | GHCup
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+
+-- | All necessary information of a tool version, including
+-- source download and per-architecture downloads.
+data VersionInfo = VersionInfo
+  { _viTags     :: [Tag]              -- ^ version specific tag
+  , _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
+  , _viArch     :: ArchitectureSpec   -- ^ descend for binary downloads per arch
+  }
+  deriving (Eq, Show)
+
+
+-- | A tag. These are currently attached to a version of a tool.
+data Tag = Latest
+         | Recommended
+         deriving (Ord, Eq, Show)
+
+
+data Architecture = A_64
+                  | A_32
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+
+data Platform = Linux LinuxDistro
+              -- ^ must exit
+              | Darwin
+              -- ^ must exit
+              | FreeBSD
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+data LinuxDistro = Debian
+                 | Ubuntu
+                 | Mint
+                 | Fedora
+                 | CentOS
+                 | RedHat
+                 | Alpine
+                 | AmazonLinux
+                 -- rolling
+                 | Gentoo
+                 | Exherbo
+                 -- not known
+                 | UnknownLinux
+                 -- ^ must exit
+  deriving (Eq, GHC.Generic, Ord, Show)
+
+
+-- | An encapsulation of a download. This can be used
+-- to download, extract and install a tool.
+data DownloadInfo = DownloadInfo
+  { _dlUri    :: URI
+  , _dlSubdir :: Maybe (Path Rel)
+  , _dlHash   :: Text
+  }
+  deriving (Eq, Show)
+
+
+
+
+    --------------
+    --[ Others ]--
+    --------------
+
+
+-- | Where to fetch GHCupDownloads from.
+data URLSource = GHCupURL
+               | OwnSource URI
+               | OwnSpec GHCupDownloads
+               deriving Show
+
+
 data Settings = Settings
   { cache     :: Bool
   , urlSource :: URLSource
+  , noVerify  :: Bool
   }
   deriving Show
 
@@ -32,66 +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
-                 -- 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
@@ -105,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

@@ -12,11 +12,12 @@
 module GHCup.Types.JSON where
 
 import           GHCup.Types
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
 
 import           Data.Aeson
 import           Data.Aeson.TH
 import           Data.Aeson.Types
-import           Data.String.QQ
 import           Data.Text.Encoding             ( decodeUtf8 )
 import           Data.Text.Encoding            as E
 import           Data.Versions
@@ -28,20 +29,17 @@ import qualified Data.ByteString               as BS
 import qualified Data.Text                     as T
 
 
-
-
-deriveJSON defaultOptions ''Architecture
-deriveJSON defaultOptions ''LinuxDistro
-deriveJSON defaultOptions ''Mess
-deriveJSON defaultOptions ''Platform
-deriveJSON defaultOptions ''SemVer
-deriveJSON defaultOptions ''Tool
-deriveJSON defaultOptions ''VSep
-deriveJSON defaultOptions ''VUnit
-deriveJSON defaultOptions ''VersionInfo
-deriveJSON defaultOptions ''Tag
-deriveJSON defaultOptions ''DownloadInfo
-deriveJSON defaultOptions ''GHCupDownloads
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
 
 
 instance ToJSON URI where

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

@@ -4,14 +4,20 @@
 {-# LANGUAGE TemplateHaskell       #-}
 
 
-module GHCup.Utils where
+module GHCup.Utils
+  ( module GHCup.Utils.Dirs
+  , module GHCup.Utils
+  )
+where
 
 
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Dirs
 import           GHCup.Utils.File
 import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
 
 import           Control.Applicative
 import           Control.Exception.Safe
@@ -25,7 +31,6 @@ import           Data.ByteString                ( ByteString )
 import           Data.List
 import           Data.Maybe
 import           Data.String.Interpolate
-import           Data.String.QQ
 import           Data.Versions
 import           Data.Word8
 import           GHC.IO.Exception
@@ -38,7 +43,7 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           Safe
-import           System.Posix.Env.ByteString    ( getEnv )
+import           System.IO.Error
 import           System.Posix.FilePath          ( takeFileName )
 import           System.Posix.Files.ByteString  ( readSymbolicLink )
 import           URI.ByteString
@@ -54,27 +59,11 @@ import qualified Data.Text.Encoding            as E
 
 
 
-    -----------------
-    --[ Utilities ]--
-    -----------------
 
 
-ghcupBaseDir :: IO (Path Abs)
-ghcupBaseDir = do
-  getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
-    Just r  -> parseAbs r
-    Nothing -> do
-      home <- liftIO getHomeDirectory
-      pure (home </> ([rel|.ghcup|] :: Path Rel))
-
-ghcupGHCBaseDir :: IO (Path Abs)
-ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
-
-ghcupGHCDir :: Version -> IO (Path Abs)
-ghcupGHCDir ver = do
-  ghcbasedir <- ghcupGHCBaseDir
-  verdir     <- parseRel (verToBS ver)
-  pure (ghcbasedir </> verdir)
+    ------------------------
+    --[ Symlink handling ]--
+    ------------------------
 
 
 -- | The symlink destination of a ghc tool.
@@ -95,12 +84,77 @@ 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
+
+
+
+
+    -----------------------------------
+    --[ Set/Installed introspection ]--
+    -----------------------------------
+
+
+toolAlreadyInstalled :: Tool -> Version -> IO Bool
+toolAlreadyInstalled tool ver = case tool of
+  GHC   -> ghcInstalled ver
+  Cabal -> cabalInstalled ver
+  GHCup -> pure True
+
+
 ghcInstalled :: Version -> IO Bool
 ghcInstalled ver = do
   ghcdir <- ghcupGHCDir ver
   doesDirectoryExist ghcdir
 
 
+ghcSrcInstalled :: Version -> IO Bool
+ghcSrcInstalled ver = do
+  ghcdir <- ghcupGHCDir ver
+  doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
+
+
 ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
 ghcSet = do
   ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
@@ -110,18 +164,11 @@ ghcSet = do
     link <- readSymbolicLink $ toFilePath ghcBin
     Just <$> ghcLinkVersion link
 
-ghcupBinDir :: IO (Path Abs)
-ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
-
-ghcupCacheDir :: IO (Path Abs)
-ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
 
 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
@@ -132,6 +179,13 @@ cabalSet = do
     Left  e -> throwM e
     Right r -> pure r
 
+
+
+    -----------------------------------------
+    --[ Major version introspection (X.Y) ]--
+    -----------------------------------------
+
+
 -- | We assume GHC is in semver format. I hope it is.
 getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
 getGHCMajor ver = do
@@ -160,17 +214,19 @@ getGHCForMajor major' minor' = do
     $ semvers
 
 
-urlBaseName :: MonadThrow m
-            => ByteString  -- ^ the url path (without scheme and host)
-            -> m (Path Rel)
-urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
+
+
+    -----------------
+    --[ Unpacking ]--
+    -----------------
+
 
 
 -- | Unpack an archive to a temporary directory and return that path.
 unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
             => Path Abs       -- ^ destination dir
             -> Path Abs       -- ^ archive path
-            -> Excepts '[ArchiveError] m ()
+            -> Excepts '[UnknownArchive] m ()
 unpackToDir dest av = do
   let fp = E.decodeUtf8 (toFilePath av)
   lift $ $(logInfo) [i|Unpacking: #{fp}|]
@@ -191,33 +247,15 @@ unpackToDir dest av = do
     | otherwise -> throwE $ UnknownArchive fn
 
 
--- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
--- while ignoring *-<ver> symlinks.
-ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
-             => Version
-             -> Excepts '[NotInstalled] m [Path Rel]
-ghcToolFiles ver = do
-  ghcdir <- liftIO $ ghcupGHCDir ver
 
-  -- fail if ghc is not installed
-  whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
-        (throwE (NotInstalled $ ToolRequest GHC ver))
 
-  files         <- liftIO $ getDirsFiles' (ghcdir </> ([rel|bin|] :: Path Rel))
-  -- 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))
-          )
-  when (B.null symver)
-       (throwIO $ userError $ "Fatal: ghc symlink target is broken")
-  pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
+    ------------
+    --[ Tags ]--
+    ------------
 
 
 -- | 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))
@@ -226,15 +264,67 @@ 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
 
 
+
+    -----------------------
+    --[ Settings Getter ]--
+    -----------------------
+
+
 getUrlSource :: MonadReader Settings m => m URLSource
 getUrlSource = ask <&> urlSource
 
 getCache :: MonadReader Settings m => m Bool
 getCache = ask <&> cache
+
+
+
+    -------------
+    --[ Other ]--
+    -------------
+
+
+urlBaseName :: MonadThrow m
+            => ByteString  -- ^ the url path (without scheme and host)
+            -> m (Path Rel)
+urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
+
+
+-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
+-- while ignoring *-<ver> symlinks.
+--
+-- Returns unversioned relative files, e.g.:
+--   ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
+ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
+             => Version
+             -> Excepts '[NotInstalled] m [Path Rel]
+ghcToolFiles ver = do
+  ghcdir <- liftIO $ ghcupGHCDir ver
+  let bindir = ghcdir </> [rel|bin|]
+
+  -- fail if ghc is not installed
+  whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
+        (throwE (NotInstalled GHC ver))
+
+  files         <- liftIO $ getDirsFiles' bindir
+  -- figure out the <ver> suffix, because this might not be `Version` for
+  -- alpha/rc releases, but x.y.a.somedate.
+  (Just symver) <-
+    (B.stripPrefix [s|ghc-|] . takeFileName)
+      <$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> [rel|ghc|]))
+  when (B.null symver)
+       (throwIO $ userError $ "Fatal: ghc symlink target is broken")
+
+  pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
+
+
+-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
+-- this GHC was built from source. It contains the build config.
+ghcUpSrcBuiltFile :: Path Rel
+ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]

lib/GHCup/Utils/Dirs.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE QuasiQuotes           #-}
+
+module GHCup.Utils.Dirs where
+
+
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
+
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Maybe
+import           Data.Versions
+import           HPath
+import           HPath.IO
+import           Optics
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
+import           System.Posix.Env.ByteString    ( getEnv
+                                                , getEnvDefault
+                                                )
+import           System.Posix.Temp.ByteString   ( mkdtemp )
+
+import qualified Data.ByteString.UTF8          as UTF8
+import qualified System.Posix.FilePath         as FP
+import qualified System.Posix.User             as PU
+
+
+
+    -------------------------
+    --[ GHCup directories ]--
+    -------------------------
+
+
+ghcupBaseDir :: IO (Path Abs)
+ghcupBaseDir = do
+  getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
+    Just r  -> parseAbs r
+    Nothing -> do
+      home <- liftIO getHomeDirectory
+      pure (home </> ([rel|.ghcup|] :: Path Rel))
+
+ghcupGHCBaseDir :: IO (Path Abs)
+ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
+
+ghcupGHCDir :: Version -> IO (Path Abs)
+ghcupGHCDir ver = do
+  ghcbasedir <- ghcupGHCBaseDir
+  verdir     <- parseRel (verToBS ver)
+  pure (ghcbasedir </> verdir)
+
+
+ghcupBinDir :: IO (Path Abs)
+ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
+
+ghcupCacheDir :: IO (Path Abs)
+ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
+
+ghcupLogsDir :: IO (Path Abs)
+ghcupLogsDir = ghcupBaseDir <&> (</> ([rel|logs|] :: Path Rel))
+
+
+mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
+mkGhcupTmpDir = do
+  tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
+  tmp    <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
+  parseAbs tmp
+
+
+withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
+withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
+
+
+    --------------
+    --[ Others ]--
+    --------------
+
+
+getHomeDirectory :: IO (Path Abs)
+getHomeDirectory = do
+  e <- getEnv [s|HOME|]
+  case e of
+    Just fp -> parseAbs fp
+    Nothing -> do
+      h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
+      parseAbs $ UTF8.fromString h -- this is a guess

lib/GHCup/Utils/File.hs

@@ -3,19 +3,17 @@
 
 module GHCup.Utils.File where
 
+import           GHCup.Utils.Dirs
 import           GHCup.Utils.Prelude
 
 import           Control.Exception.Safe
 import           Control.Monad
-import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Resource
 import           Data.ByteString
 import           Data.ByteString.Unsafe         ( unsafeUseAsCStringLen )
 import           Data.Char
 import           Data.Foldable
 import           Data.Functor
 import           Data.Maybe
-import           Data.String.QQ
 import           GHC.Foreign                    ( peekCStringLen )
 import           GHC.IO.Encoding                ( getLocaleEncoding )
 import           GHC.IO.Exception
@@ -27,28 +25,23 @@ import           Streamly.External.ByteString
 import           Streamly.External.ByteString.Lazy
 import           System.IO
 import           System.Posix.Directory.ByteString
-import           System.Posix.Env.ByteString
 import           System.Posix.FD               as FD
 import           System.Posix.FilePath   hiding ( (</>) )
 import           System.Posix.Foreign           ( oExcl )
 import "unix"    System.Posix.IO.ByteString
                                          hiding ( openFd )
 import           System.Posix.Process           ( ProcessStatus(..) )
-import           System.Posix.Temp.ByteString
 import           System.Posix.Types
 
 
 import qualified System.Posix.Process.ByteString
                                                as SPPB
-import qualified System.Posix.FilePath         as FP
-import qualified System.Posix.User             as PU
 import           Streamly.External.Posix.DirStream
 import qualified Streamly.Internal.Memory.ArrayStream
                                                as AS
 import qualified Streamly.FileSystem.Handle    as FH
 import qualified Streamly.Internal.Data.Unfold as SU
 import qualified Streamly.Prelude              as S
-import qualified Data.ByteString.UTF8          as UTF8
 import qualified Data.ByteString.Lazy          as L
 
 
@@ -115,6 +108,36 @@ executeOut path args chdir = captureOutStreams $ do
   SPPB.executeFile (toFilePath path) True args Nothing
 
 
+execLogged :: ByteString       -- ^ thing to execute
+           -> Bool             -- ^ whether to search PATH for the thing
+           -> [ByteString]     -- ^ args for the thing
+           -> Path Rel         -- ^ log filename
+           -> Maybe (Path Abs) -- ^ optionally chdir into this
+           -> Maybe [(ByteString, ByteString)] -- ^ optional environment
+           -> IO (Either ProcessError ())
+execLogged exe spath args lfile chdir env = do
+  ldir <- ghcupLogsDir
+  let logfile = ldir </> lfile
+  bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
+ where
+  action fd = do
+    pid <- SPPB.forkProcess $ do
+      -- dup stdout
+      void $ dupTo fd stdOutput
+
+      -- dup stderr
+      void $ dupTo fd stdError
+
+      -- execute the action
+      maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+      SPPB.executeFile exe spath args env
+
+
+    SPPB.getProcessStatus True True pid >>= \case
+      i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
+      i                         -> pure $ toProcessError exe args i
+
+
 -- | Capture the stdout and stderr of the given action, which
 -- is run in a subprocess. Stdin is closed. You might want to
 -- 'race' this to make sure it terminates.
@@ -193,33 +216,12 @@ toProcessError exe args mps = case mps of
   Nothing                            -> Left $ NoSuchPid exe args
 
 
-mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
-mkGhcupTmpDir = do
-  tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
-  tmp    <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
-  parseAbs tmp
-
-
-withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
-withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
-
-
-getHomeDirectory :: IO (Path Abs)
-getHomeDirectory = do
-  e <- getEnv [s|HOME|]
-  case e of
-    Just fp -> parseAbs fp
-    Nothing -> do
-      h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
-      parseAbs $ UTF8.fromString h -- this is a guess
-
-
 -- | 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

@@ -1,28 +1,60 @@
+{-# LANGUAGE QuasiQuotes           #-}
+
 module GHCup.Utils.Logger where
 
+import           GHCup.Utils
 
+import           Control.Monad
 import           Control.Monad.Logger
+import           HPath
+import           HPath.IO
+import           Prelude                 hiding ( appendFile )
 import           System.Console.Pretty
+import           System.IO.Error
 
-import qualified Data.ByteString as B
+import qualified Data.ByteString               as B
 
 
-data LoggerConfig = LoggerConfig {
-    lcPrintDebug :: Bool
-  , outter :: B.ByteString -> IO ()
-}
+data LoggerConfig = LoggerConfig
+  { lcPrintDebug :: Bool                  -- ^ whether to print debug in colorOutter
+  , colorOutter  :: B.ByteString -> IO () -- ^ how to write the color output
+  , rawOutter    :: B.ByteString -> IO () -- ^ how to write the full raw output
+  }
 
 
 myLoggerT :: LoggerConfig -> LoggingT m a -> m a
-myLoggerT LoggerConfig{..} loggingt = runLoggingT loggingt mylogger
+myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
  where
   mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
   mylogger _ _ level str' = do
+    -- color output
     let l = case level of
-          LevelDebug   -> if lcPrintDebug then toLogStr (style Bold $ color Blue   "[ Debug ]") else mempty
-          LevelInfo    -> toLogStr (style Bold $ color Green  "[ Info  ]")
+          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 ]")
+          LevelError   -> toLogStr (style Bold $ color Red "[ Error ]")
           LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
-    let out = fromLogStr (l <>  toLogStr " " <> str' <> toLogStr "\n")
-    outter out
+    let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
+
+    when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
+      $ colorOutter out
+
+    -- raw output
+    let lr = case level of
+          LevelDebug   -> toLogStr "Debug: "
+          LevelInfo    -> toLogStr "Info:"
+          LevelWarn    -> toLogStr "Warn:"
+          LevelError   -> toLogStr "Error:"
+          LevelOther t -> toLogStr t <> toLogStr ":"
+    let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
+    rawOutter outr
+
+
+initGHCupFileLogging :: Path Rel -> IO (Path Abs)
+initGHCupFileLogging context = do
+  logs <- ghcupLogsDir
+  let logfile = logs </> context
+  createDirIfMissing newDirPerms logs
+  hideError doesNotExistErrorType $ deleteFile logfile
+  createRegularFile newFilePerms logfile
+  pure logfile

lib/GHCup/Utils/Prelude.hs

@@ -1,15 +1,12 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveLift #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveLift          #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module GHCup.Utils.Prelude where
 
@@ -24,15 +21,10 @@ import           Data.Monoid                    ( (<>) )
 import           Data.String
 import           Data.Text                      ( Text )
 import           Data.Versions
-import           GHC.Base
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
-import           Language.Haskell.TH.Syntax     ( Exp(..)
-                                                , Lift
-                                                )
 import           System.IO.Error
+import           System.Posix.Env.ByteString    ( getEnvironment )
 
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
@@ -42,7 +34,6 @@ import qualified Data.Text.Lazy                as TL
 import qualified Data.Text.Lazy.Builder        as B
 import qualified Data.Text.Lazy.Builder.Int    as B
 import qualified Data.Text.Lazy.Encoding       as TLE
-import qualified Language.Haskell.TH.Syntax    as TH
 
 
 
@@ -147,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
@@ -165,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)
@@ -185,15 +189,32 @@ 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
-           -> Excepts es m ()
-           -> Excepts es' m ()
+             . (Monad m, e :< es, LiftVariant (Remove e es) es')
+            => e
+            -> Excepts es m ()
+            -> Excepts es' m ()
 hideExcept' _ action =
   catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
 
 
+reThrowAll :: forall e es es' a m
+            . (Monad m, e :< es')
+           => (V es -> e)
+           -> Excepts es m a
+           -> Excepts es' m a
+reThrowAll f = catchAllE (throwE . f)
+
+
+reThrowAllIO :: forall e es es' a m
+              . (MonadCatch m, Monad m, MonadIO m, e :< es')
+             => (V es -> e)
+             -> (IOException -> e)
+             -> Excepts es m a
+             -> Excepts es' m a
+reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)
+
 
 throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
 throwEither a = case a of
@@ -201,63 +222,22 @@ throwEither a = case a of
   Right r -> pure r
 
 
-
-deriving instance Lift Versioning
-deriving instance Lift Version
-deriving instance Lift SemVer
-deriving instance Lift Mess
-deriving instance Lift PVP
-deriving instance Lift (NonEmpty Word)
-deriving instance Lift VSep
-deriving instance Lift VUnit
-instance Lift Text
-
-qq :: (Text -> Q Exp) -> QuasiQuoter
-qq quoteExp' = QuasiQuoter
-  { quoteExp  = (\s -> quoteExp' . T.pack $ s)
-  , quotePat  = \_ ->
-    fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
-  , quoteType = \_ ->
-    fail "illegal QuasiQuote (allowed as expression only, used as a type)"
-  , quoteDec  = \_ -> fail
-    "illegal QuasiQuote (allowed as expression only, used as a declaration)"
-  }
-
-vver :: QuasiQuoter
-vver = qq mkV
- where
-  mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . version
-
-mver :: QuasiQuoter
-mver = qq mkV
- where
-  mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . mess
-
-sver :: QuasiQuoter
-sver = qq mkV
- where
-  mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . semver
-
-vers :: QuasiQuoter
-vers = qq mkV
- where
-  mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . versioning
-
-pver :: QuasiQuoter
-pver = qq mkV
- where
-  mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . pvp
-
-
 verToBS :: Version -> ByteString
 verToBS = E.encodeUtf8 . prettyVer
 
 
-
 intToText :: Integral a => a -> T.Text
 intToText = TL.toStrict . B.toLazyText . B.decimal
+
+
+removeLensFieldLabel :: String -> String
+removeLensFieldLabel str' =
+  maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
+
+
+addToCurrentEnv :: MonadIO m
+                => [(ByteString, ByteString)]
+                -> m [(ByteString, ByteString)]
+addToCurrentEnv adds = do
+  cEnv <- liftIO $ getEnvironment
+  pure (adds ++ cEnv)

lib/GHCup/Utils/String/QQ.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
+--
+-- The "s" quoter contains a multi-line string with no interpolation at all,
+-- except that the leading newline is trimmed and carriage returns stripped.
+--
+-- @
+-- {-\# LANGUAGE QuasiQuotes #-}
+-- import Data.Text (Text)
+-- import Data.String.QQ
+-- foo :: Text -- "String", "ByteString" etc also works
+-- foo = [s|
+-- Well here is a
+--     multi-line string!
+-- |]
+-- @
+--
+-- Any instance of the IsString type is permitted.
+--
+-- (For GHC versions 6, write "[$s||]" instead of "[s||]".)
+--
+module GHCup.Utils.String.QQ
+  ( s
+  )
+where
+
+
+import           Data.Char
+import           GHC.Exts                       ( IsString(..) )
+import           Language.Haskell.TH.Quote
+
+-- | QuasiQuoter for a non-interpolating ASCII IsString literal.
+-- The pattern portion is undefined.
+s :: QuasiQuoter
+s = QuasiQuoter
+  (\s' -> case and $ fmap isAscii s' of
+    True  -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
+    False -> fail "Not ascii"
+  )
+  (error "Cannot use q as a pattern")
+  (error "Cannot use q as a type")
+  (error "Cannot use q as a dec")
+ where
+  removeCRs = filter (/= '\r')
+  trimLeadingNewline ('\n' : xs) = xs
+  trimLeadingNewline xs          = xs
+

lib/GHCup/Utils/Version/QQ.hs

@@ -0,0 +1,89 @@
+{-# OPTIONS_GHC -Wno-orphans    #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveLift         #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell    #-}
+
+
+module GHCup.Utils.Version.QQ where
+
+import           Data.Data
+import           Data.Text                      ( Text )
+import           Data.Versions
+import           GHC.Base
+import           Language.Haskell.TH
+import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
+import           Language.Haskell.TH.Syntax     ( Exp(..)
+                                                , Lift
+                                                , dataToExpQ
+                                                )
+import qualified Data.Text                     as T
+import qualified Language.Haskell.TH.Syntax    as TH
+
+
+
+deriving instance Data Versioning
+deriving instance Lift Versioning
+deriving instance Data Version
+deriving instance Lift Version
+deriving instance Data SemVer
+deriving instance Lift SemVer
+deriving instance Data Mess
+deriving instance Lift Mess
+deriving instance Data PVP
+deriving instance Lift PVP
+deriving instance Lift (NonEmpty Word)
+deriving instance Lift VSep
+deriving instance Data VSep
+deriving instance Lift VUnit
+deriving instance Data VUnit
+instance Lift Text
+
+qq :: (Text -> Q Exp) -> QuasiQuoter
+qq quoteExp' = QuasiQuoter
+  { quoteExp  = (\s -> quoteExp' . T.pack $ s)
+  , quotePat  = \_ ->
+    fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
+  , quoteType = \_ ->
+    fail "illegal QuasiQuote (allowed as expression only, used as a type)"
+  , quoteDec  = \_ -> fail
+    "illegal QuasiQuote (allowed as expression only, used as a declaration)"
+  }
+
+vver :: QuasiQuoter
+vver = qq mkV
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) liftDataWithText . version
+
+mver :: QuasiQuoter
+mver = qq mkV
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) liftDataWithText . mess
+
+sver :: QuasiQuoter
+sver = qq mkV
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) liftDataWithText . semver
+
+vers :: QuasiQuoter
+vers = qq mkV
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) liftDataWithText . versioning
+
+pver :: QuasiQuoter
+pver = qq mkV
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) liftDataWithText . pvp
+
+-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
+liftText :: T.Text -> Q Exp
+liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
+
+liftDataWithText :: Data a => a -> Q Exp
+liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)

lib/GHCup/Version.hs

@@ -3,8 +3,9 @@
 
 module GHCup.Version where
 
+import           GHCup.Utils.Version.QQ
+
 import           Data.Versions
-import           GHCup.Utils.Prelude
 
 ghcUpVer :: PVP
 ghcUpVer = [pver|0.1.0|]